I have a current MS Outlook VBA Macro to remove all attachments from an email apart from attachments of one specific filetype (not my code, hobbled together from a few posts on here) and it works great.
Dim objSelection As Outlook.Selection
Dim i, n As Long
Dim objMail As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
Dim strFileType As String
'Get the selected emails
Set objSelection = Outlook.Application.ActiveExplorer.Selection
'Process each email one by one
For i = objSelection.Count To 1 Step -1
If TypeOf objSelection(i) Is MailItem Then
Set objMail = objSelection(i)
If objMail.Attachments.Count > 0 Then
For n = objMail.Attachments.Count To 1 Step -1
Set objAttachment = objMail.Attachments.Item(n)
'Get the attachment file type
strFileType = Right(objAttachment.FileName, Len(objAttachment.FileName) - InStr(1, objAttachment.FileName, "."))
'Leave 'obr' attachments, Delete all other types of attachments
Select Case strFileType
Case is <> "obr"
objAttachment.Delete
Case Else
End Select
Next
objMail.Save
End If
End If
Next i
End Sub
However i've found i have a need to record what attachments were deleted, so i can search for the filenames and then recover the original email from the backup server. Therefore what i'm after is to insert the filenames of the deleted attachments into the emails they are deleted from.
I'm not concerned about the location, so the top is fine, something along the lines of:
<<Attachment deleted: attachment name.pdf>>
Keep in mind that you need to modify HTMLBody, not plain text Body - otherwise the formatting will be lost. And you cannot concatenate two HTML strings - you must merge the two: find the position of the <body substring, find the next > (this way you take care of the body tags with attributes) and insert your text after that.
Sub DelAtt()
Dim objSelection As Outlook.Selection
Dim i, n As Long
Dim objMail As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
Dim strFileType As String
Dim del_att_list As String
'Get the selected emails
Set objSelection = Outlook.Application.ActiveExplorer.Selection
'Process each email one by one
For i = objSelection.Count To 1 Step -1
If TypeOf objSelection(i) Is MailItem Then
Set objMail = objSelection(i)
If objMail.Attachments.Count > 0 Then
For n = objMail.Attachments.Count To 1 Step -1
Set objAttachment = objMail.Attachments.Item(n)
'Get the attachment file type
strFileType = Right(objAttachment.FileName, Len(objAttachment.FileName) - InStrRev(objAttachment.FileName, ".")) ' InStrRev instead of InStr to find exactly the last dot
'Leave 'obr' attachments, Delete all other types of attachments
Select Case strFileType
Case Is <> "obr"
del_att_list = del_att_list & Replace("<<Attachment deleted: #>>", "#", objAttachment.FileName) & vbLf ' add filename to list of deleted attachments
objAttachment.Delete
Case Else
End Select
Next
If del_att_list <> "" Then 'smth was deleted
With objMail
.Body = del_att_list & vbLf & .Body ' add lines to the body top
.Save
End With
End If
End If
End If
Next i
End Sub
Before
After
Related
I'm working on a VBA script for Outlook, that sorts emails so only emails with PDF files are in the inbox.
I have thanks to a previous answered question in Stackoverflow gotten this VBA script working and doing the tasks.
Sub MoveMail(Item As Outlook.MailItem)
If Item.Attachments.Count > 0 Then
Dim attCount As Long
Dim strFile As String
Dim sFileType As String
attCount = Item.Attachments.Count
For i = attCount To 1 Step -1
strFile = Item.Attachments.Item(i).FileName
sFileType = LCase$(Right$(strFile, 4))
Select Case sFileType
Case ".txt", ".doc", "docx", ".xls", "xlsx"
' do something if the file types are found
' this code moves the message
Item.Move (Session.GetDefaultFolder(olFolderInbox).Folders("Reply"))
' stop checking if a match is found and exit sub
GoTo endsub
End Select
Next i
End If
endsub:
Set Item = Nothing
End Sub
I need to also sort emails without attachment.
How do I check emails if the attachment is other then PDF or doesn't have any attachment then move it to a folder in Outlook called Reply?
Used solution found on Moving emails with specified attachments from shared inbox to a different folder of the same shared mailbox
It answered my questions and gave me the info needed to find a solutions to my own questions and made it possible to create this script
Sub MoveMail(Item As Outlook.MailItem)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move (Session.GetDefaultFolder(olFolderInbox).Folders("Reply"))
End If
Set myAtt = Nothing
Set pa = Nothing
End Sub
I am trying to create a code that will parse Inbox folder in Outlook and organize emails based on several criteria.
If there is a number between brackets. For example (123456)
If there are attachments in email item. Attachment should be more than 10000 to skip Signatures
Logic:
If both criteria match -> Send to Folder1
If one of them does not match (attachments are missing or there is no number between brackets), send to Archive
Criteria 1 is functioning correct, but I have problems adding criteria 2 for attachments.
Here is my current code:
Private Sub olInboxMainItems_ItemAdd(ByVal Item As Object)
'On Error Resume Next
Dim SubjectVar1 As String
Dim openPos1 As Integer
Dim closePos1 As Integer
Dim midBit1 As String
Dim objNamespace1 As Outlook.NameSpace
Dim destinationFolder1 As Outlook.MAPIFolder
Dim ArchiveFolder As Outlook.MAPIFolder
Dim objAttachments As Outlook.Attachments
Dim AttCount As Long
Set objNamespace1 = GetNamespace("MAPI")
Set destinationFolder1 = objNamespace1.Folders("mybox#mail.com").Folders("Inbox").Folders("Folder1")
Set ArchiveFolder = objNamespace1.Folders("mybox#mail.com").Folders("Archive")
Set objAttachments = Item.Attachments
' Check is there a number between brackets
SubjectVar1 = Item.Subject
openPos1 = InStr(SubjectVar1, "(")
closePos1 = InStr(SubjectVar1, ")")
midBit1 = Mid(SubjectVar1, openPos1 + 1, closePos1 - openPos1 - 1)
' Count number of attachments bigger than 10000 bytes
For s = lngCount To 1 Step -1
If objAttachments.Item(s).Size > 10000 Then
' Count attachments.
AttCount = objAttachments.Item(s).Count
End If
Next s
' Perform actions
If midBit1 = "" And AttCount < 1 Then
Item.Move ArchiveFolder
'GoTo EndOfScript
Else
'MsgBox (midBit)
Item.Move destinationFolder1
'GoTo EndOfScript
End If
EndOfScript:
Set destinationFolder1 = Nothing
Set objNamespace1 = Nothing
End Sub
EDIT:
Here is a simple version I am trying to get working for selected email message:
Sub CountAttachmentsinSelectedEmails()
Dim olSel As Selection
Dim oMail As Object
Dim s As Long
Dim AttCount As Long
Dim strMsg As String
Dim nRes
Dim lngCount As Long
Dim objAttachments As Outlook.Attachments
Dim strFile As String
Set olSel = Outlook.Application.ActiveExplorer.Selection
For Each oMail In olSel
For s = lngCount To 1 Step -1
If objAttachments.Item(s).Size > 10000 Then
strFile = objAttachments.Item(s).Count + 1
End If
Next s
Next
MsgBox ("There are " & strFile & " attachments in the ")
End Sub
Result is empty? No numbers at all
EDIT 2:
Sub CountAttachmentsinSelectEmails()
Dim olSel As Selection
Dim oMail As Object
Dim s As Long
Dim objAttachments As Outlook.Attachments
Dim NumFiles As Long
Dim oItem As Object
Set olSel = Outlook.Application.ActiveExplorer.Selection
Set objAttachments = oItem.Attachments
For Each oMail In olSel
For s = objAttachments.Count To 1 Step -1
If objAttachments.Item(s).Size > 10000 Then
NumFiles = NumFiles + 1
End If
Next s
Next
Debug.Print NumFiles
End Sub
Item.Attachments is a collection therefore so is objAttachments.
A collection can have zero or more members. objAttachments.Count is the number of members which you do not check.
You need to loop over the attachments to check their size and extension individually. Signatures, logos and so on count as attachments but I assume you are not interested in them. Could there be more than one interesting attachment? Do you want a total size of 10,000 or any one attachment being more than 10,000 bytes?
When accessing the size you need to specify which attachment you are checking: objAttachments.Item(Index).Size.
The above should you give you some pointers but I can explain in more detail if necessary.
Comments on edit 1
You do not set objAttachments to anything. Add Set objAttachments = oItem.Attachments.
In For s = lngCount To 1 Step -1 you do not set lngCount to a value so it defaults to zero and the for body is never performed. Try For s = objAttachments.Count To 1 Step -1.
strFile is a string but you are using it in a numeric expression. This will work because the interpreter will evaluate the expression and then convert it to a string. However, the value is objAttachments.Item(s).Count + 1. If there are five attachments and any one of them is larger than 10,000 bytes, the answer will be six.
You need something like Dim NumFiles As Long. This will be initialised to 0. Within the If you need NumFiles = NumFiles + 1.
I rarely use MsgBox for diagnostics. I find Debug.Print NumFiles more convenient. If I want to stop execution, I use Debug.Assert False.
Comments on Edit 2
This is the routine I use to test new email handling macros. The relevance is it show how to use Outlook’s Explorer correctly.
Sub TestNewMacro()
' Skeleton for testing a new mail item processing macro using Explorer
' Replace statement marked ##### with call of new macro.
' Add code to create parameters for new test macro and remove any code to
' create parameters for old test macro.
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Dim PathSave As String
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
PathSave = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Please select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call MacroToBeTested(ItemCrnt, PathSave) ' #####
Next
End If
End Sub
I want search though Outlook folders of now to previous weekday, so will exclude weekends, and if file doesn’t exist, output “this report was not sent on date”.
And for file to save as: following a condition that the title of the heading contains some text at most two. And that the file will be saved with the two found letters in the body of the title.
I want to do this for six different cases.
Sub SaveOutlookAttachments()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim ofolder As Outlook.folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set ofolder = ns.Folders(1).Folders("Inbox")
For Each i In ofolder.Items
If i.Class = olMail Then
Set mi = i 'This ensure that were looking at an email object rather than any potential item
'I need to find a way to create a case or an if statement that would reference 2 keywords in the title of the email subject in order to download and save the file with those keywords + date at the end.
'The logic is to use the title to distinguish between 4 regional reports for 1 Partner and 3 reports for 3 different partners. These would save files in their names associated with the title of the email. Eg: Comp.ABC Regional Reports 20/10/2019. I should also only search for previous days only within weekdays/working days - Mondays to Fridays.
Debug.Print mi.SenderName, mi.ReceivedTime, mi.Attachments.Count
For Each at In mi.Attachments
at.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & at.FileName & Format(mi.ReceivedTime, "dd-mm-yyyy") 'Put in a valid folder location to store attachements
Next at
End If
Next i
End Sub
Here's code that first checks the MailItem's ReceivedTime for the Date condition (you can go further and exclude weekends). Then it checks the MailItem's Subject for Keywords from a colKeywords collection you can edit and add to. It also This should get you pretty close to what you want to do. I've also renamed the variables for clarity:
Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.Folder
Dim objItem As Object
Dim objMailItem As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
Dim colKeywords As New Collection
Dim sKeyword As String
Dim iCounter As Integer
Dim iBackdate As Integer
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.Folders(1).Folders("Inbox")
' Add your Keywords here
colKeywords.Add "keyword1"
colKeywords.Add "keyword2"
For Each objItem In objFolder.Items
' Check Item Class
If objItem.Class = Outlook.olMail Then
' Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Loop through all keywords
For iCounter = 1 To colKeywords.Count
' Get keyword
sKeyword = colKeywords.Item(iCounter)
' Check if keyword exists
If InStr(.Subject, sKeyword) > 0 Then
' Save Attachments
For Each objAttachment In .Attachments
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & objAttachment.FileName & Format(.ReceivedTime, "dd-mm-yyyy") 'Put in a valid folder location to store attachements
Next
End If
Next
End If
End With
End If
Next
I have a Company Project where ~500 clients send Emails to the my project inbox. Those clients correspond to ~150 offices (I have an Excel-List of the email addresses & according offices).
Each office shall have one Outlook folder, so I can quickly check upon the past correspondence with a specific office.
The Project inbox is looked after and used by several co-workers, hence server- and not client based rules.
How do I set this up?
My simple idea in form of a pseudo code:
for each arriving email
if (from-adress is in "email & office-List")
move that email to outlook folder "according office name"
end if
end for
and the same for outgoing emails:
for each sent email
if (to-adress is in "email & office-List")
move that email to outlook folder "according office name"
end if
end for
Thanks for suggestions!
...and besides, can outlook folders be created programmatically from a list of names?
My solution is a skript i run daily on a manual basis since my employer doesnt allow scripts on arriving messages.
the logic in short is:
fetch list of emails & their corresponding offices (both string lists)
set up folder variables
loop through messages, and move them eventually
the code looks like
Option Compare Text ' makes string comparisons case insensitive
Sub sortEmails()
'sorts the emails into folders
Dim msg As Outlook.MailItem
Dim itm As Object
Dim adress As String
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
'1) fetch emails
GetEMailsFolders locIDs, emails, n
'1.5) fetch folder objects
'Create an instance of Outlook & inbox reference
Dim Inbox As Outlook.MAPIFolder
Dim outbox As Outlook.MAPIFolder
Set outlookApp = New Outlook.Application
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("email#host.com")
objOwner.Resolve
'Set inbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Inbox = NS.Folders("email#host.com").Folders("Inbox")
Set outbox = NS.Folders("email#host.com").Folders("Sent Items")
Dim basefolder As Outlook.MAPIFolder
Dim bfName As String
bfName = "Offices" 'name of the folder for the offices
Set basefolder = MkDirConditional(Inbox.Folders("Project folder"), bfName)
'2)loop through inbox & outbox emails
Dim destination As Outlook.MAPIFolder
Dim fold(1 To 2) As Outlook.MAPIFolder
Set fold(1) = Inbox
Set fold(2) = outbox
Dim LocID As String
For Each fol In fold 'loop through inbox & outbox
Debug.Print fol
'reverse fo loop because otherwise moved messages modify indices of following messages
For i = fol.Items.Count To 1 Step -1 'Each itm In fol.Items
Set itm = fol.Items(i)
If TypeName(itm) = "MailItem" Then ' others are AppointmentItem, MeetingItem, or TaskItem
Set msg = itm
'Debug.Print " " & msg.Subject
If fol = Inbox Then
' there are two formats of email adrersses.
If msg.SenderEmailType = "EX" Then 'check two kinds of email adress formats
adress = msg.Sender.GetExchangeUser().PrimarySmtpAddress
ElseIf msg.SenderEmailType = "SMTP" Then 'SMTP case
adress = msg.SenderEmailAddress
Else
Debug.Print " neither EX nor SMTP" & msg.Subject;
End If
pos = Findstring(adress, emails) ' position in the email / standort list
ElseIf fol = outbox Then
For Each rec In msg.Recipients
Set pa = rec.PropertyAccessor
adress = pa.GetProperty(PR_SMTP_ADDRESS)
pos = Findstring(adress, emails)
If pos > 0 Then
Exit For
End If
Next rec
End If
'4.5) if folder doesnt exist, create it
'5) move message
If pos > 0 Then
'Debug.Print " Its a Match!!"
LocID = locIDs(pos)
Set destination = MkDirConditional(basefolder, LocID)
Debug.Print " " & Left(msg.Subject, 20), adress, pos, destination
msg.Move destination
Else
'Debug.Print " not found!"
End If
Else
'Debug.Print " " & "non-mailitem", itm.Subject
End If
Next i
Next fol
End Sub
'// Function - Check folder Exist
Private Function FolderExists(Inbox As Outlook.MAPIFolder, FolderName As String) As Boolean
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function
Function MkDirConditional(basefolder As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder
Debug.Print newfolder & " ";
If FolderExists(basefolder, newfolder) Then
'folder exists, so just skip
Set MkDirConditional = basefolder.Folders(newfolder)
Debug.Print "exists already"
Else
'folder doesnt exist, make it
Set MkDirConditional = basefolder.Folders.Add(newfolder)
Debug.Print "created"
End If
End Function
'function to compare two strings, min the option compare text at the top line
Function Findstring(str As String, arr As Variant) As Integer
'returns -1 if a string is not found, otherwise its index
Findstring = -1
Dim i As Integer
i = 1
For Each Item In arr
'Debug.Print Item
If str = Item Then
Findstring = i
Exit For
End If
i = i + 1
Next
End Function
' function to fetch the lists of emails and offices
Sub GetEMailsFolders(ByRef rng1 As Variant, ByRef rng2 As Variant, ByRef n As Variant)
'declare variables
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xExcelRange As Excel.Range
Dim TotalRows As Long
'declare SPOC xls file
xExcelFile = "adresses.xlsx"
'open the file
Set xExcelApp = CreateObject("Excel.Application")
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = xWb.Sheets(1)
'extract LocIDs (column A), emails (column O) and thir number
n = xWs.Range(xWs.Range("A2"), xWs.Range("A2").End(xlDown)).Count ' works
ReDim rng1(1 To n) As Variant
ReDim rng2(1 To n) As Variant
For i = 1 To n
rng1(i) = xWs.Cells(i + 1, 1)
rng2(i) = xWs.Cells(i + 1, 15)
'Debug.Print rng1(i), rng2(i)
Next
Debug.Print "done reading LocIDs & emails"
End Sub
I'm trying to "reply all", add text to the subject, add a recipient, and remove a recipient.
Sub Reply_All()
Dim olReply As mailitem
Dim strSubject As String
For Each olItem In Application.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
Set olRecip = olReply.Recipients.Add("EmailAddressGoesHere")
Set olRecip = olReply.Recipients.Remove("EmailAddressGoesHere")
strSubject = olReply.Subject
olReply.Subject = "(Added Subject Line Info - ) " & strSubject
olReply.Display
Next
End Sub
Everything works when I comment out the Recipients.Remove line.
I noticed that
Set olRecip = olReply.Recipients.Add("EmailAddressGoesHere")
has "Add Name As String"
While
Set olRecip = olReply.Recipients.Remove("EmailAddressGoesHere")
has "Remove Index As Long" as the yellow text that comes up when you type it into the script.
Loop through the recipients using a "for" loop from Count down to 1, check the Recipient.Address property. If it matches the value you are after, call Recipients.Remove passing the current loop index.
As Dmitry mentioned, you could refer to the below code:
Sub Reply_All()
Dim olReply As MailItem
Dim strSubject As String
For Each olItem In Application.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
For Each Address In EmailAddressGoesHere
olReply.Recipients.Add (Address)
Next
For Each Rec In olReply.Recipients
Rec.Delete
Next
strSubject = olReply.Subject
olReply.Subject = "(Added Subject Line Info - ) " & strSubject
olReply.Display
Next
End Sub
For more information, please refer to this link:
remove recipient from mail.recipient collection
Option Explicit
' Consider Option Explicit mandatory
' Tools | Options | Editor tab | Require Variable Declaration
Sub Reply_All_RemoveSingleOrMultipleCopiesAddress()
Dim olItem As Object
Dim olReply As MailItem
Dim i As Long
For Each olItem In ActiveExplorer.Selection
If olItem.Class = olMail Then
Set olReply = olItem.ReplyAll
'olReply.Display
' If the address could occur once or multiple times,
' start at the end and work backwards
For i = olReply.Recipients.count To 1 Step -1
'Debug.Print olReply.Recipients(i).Address
' "EmailAddressToBeRemoved" with the quotes as shown
If LCase(olReply.Recipients(i).Address) = LCase("EmailAddressToBeRemoved") Then
olReply.Recipients.remove (i)
End If
Next
olReply.Display
End If
Next
End Sub
Sub Reply_All_RemoveSingleAddressReliably()
Dim olItem As Object
Dim olReply As MailItem
Dim recip As recipient
For Each olItem In ActiveExplorer.Selection
If olItem.Class = olMail Then
Set olReply = olItem.ReplyAll
'olReply.Display
' If the address can appear once only,
' otherwise use a downward counting loop
For Each recip In olReply.Recipients
'Debug.Print recip.Address
' "EmailAddressToBeRemoved" with the quotes as shown
If LCase(recip.Address) = LCase("EmailAddressToBeRemoved") Then
' Delete not remove
recip.Delete
' No need to continue if only one instance of address can occur,
' otherwise you would unreliably delete anyway.
' The address immediately after a deleted address is skipped
' as it moves into the old position of the deleted address.
Exit For
End If
Next
olReply.Display
End If
Next
End Sub
To whom it may concern.
You can easily try a combination of the solutions offered for a quick result:
Set myRecipients = olReply.Recipients
Dim y As Long
y = myRecipients.Count
Do Until y = 0
If myRecipients(y) = "to be removed" Then
myRecipients(y).Delete
End If
y = y - 1
Loop