I download Excel files that I get e-mailed that meet a given criteria.
If there is no attachment, I need to scrape the body of the e-mail, and paste it into an Excel document.
How do I detect if I've been sent only non-Excel attachments - For example, if someone attaches a PDF.
I figured to count the number of attachments that contain the string ".xls", and if I have more than 0 results, process the downloads. Otherwise, scrape the e-mail body.
I've found:
1) How to count the attachments
oOlItm.Attachments.Count <> 0
2) How to check if any given attachment has a given string in it
(InStr(oOlAtch.FileName, ".xls") > 0)
Something like this will work:
For Each oOlItm In oOlAtch.attachments
If InStr(1, oOlItm.filname, ".xls") > 1 Then cnt = cnt + 1
Next oOlItm
if cnt > 0 then ...
For Each oOlAtch In oOlItm.Attachments
ExcelAttachmentNumber = 0
If (InStr(oOlAtch.FileName, ".xls") > 0) Then
ExcelAttachmentNumber = ExcelAttachmentNumber + 1
Else
End If
Next
Related
I am new to macros, and I found Imnoss's "Enhanced Mail Merge to Email" code very useful for a work application of drafting emails within MS Word and automatically duplicating them with their respective text variables to draft emails.
Imnoss original code: https://imnoss.com/enhanced-mail-merge-to-email/
I made some tweaks to it to prevent a built-in functionality to automatically send the emails, which I did not want -- my purpose of using it was to simply draft emails and send them to my boss to review. The code was modified where it says "Select Case MsgBox( ..."
May somebody take a look at the code I've tweaked below and advise what could be causing the output drafted emails to sometimes duplicate as copies of two instead of drafting one email per input? Thank you very much!
Sub EnhancedMailMergeToEmail()
' Macro created by Imnoss Ltd
' Please share freely while retaining attribution
' Last Updated 2021-11-06
' REFERENCES REQUIRED!
' This Macro requires you to add the following libraries:
' "Microsoft Outlook xx.x Object Library" (replace xx.x with version number) and "Microsoft Scripting Runtime"
' To add them, use the "Tools" menu and select "References". Tick the check boxes next to the two libraries and press OK.
' declare variables
Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem
Dim outlookAccount As Outlook.Account
Dim fso As FileSystemObject
Dim f As Object
Dim attachFile As File
Dim mm As MailMerge
Dim df As MailMergeDataField
Dim singleDoc As Document
Dim mailBody As String
Dim lastRecordNum As Long
Dim recordCount As Long
Dim sendFlag As Boolean
Dim validRowFlag As Boolean
Dim tempFileName As String
Dim tempFolderName As String
Dim fieldName As String
Dim inputDate As Date
' identify the mail merge of the active document
Set mm = ActiveDocument.MailMerge
' check for the mail merge state being that of a mail merge ready to go
If mm.State <> wdMainAndDataSource Then
If MsgBox("Mailmerge not set up for active document - cannot perform mailmerge. Macro will exit.", vbOKOnly + vbCritical, "Error") = vbOK Then Exit Sub
End If
' set lastRecordNum to the number of the last active record (reached using wdLastRecord
mm.DataSource.ActiveRecord = wdLastRecord
lastRecordNum = mm.DataSource.ActiveRecord
' if the lastRecordNum is less than 50 we assume some may have been deselected so we count only the active records
' counting more than 50 records takes too long
If lastRecordNum < 50 Then
mm.DataSource.ActiveRecord = wdFirstRecord
recordCount = 0
Do While True
' run through the fields to check if a valid email address is provided in any of the "to", "cc" or "bcc" fields (valid address = contains an "#")
' also detect if the row is marked to be ignored
validRowFlag = False
For Each df In mm.DataSource.DataFields
' clean up the provided field name by running through the name letter by letter and adding only letters to the variable fieldName
fieldName = ""
For i = 1 To Len(df.Name)
Select Case Asc(LCase(Mid(df.Name, i, 1)))
Case 97 To 122
fieldName = fieldName & LCase(Mid(df.Name, i, 1))
End Select
Next i
Select Case fieldName
Case "ignore"
Select Case LCase(df.Value)
Case "true", "yes", "y", "ignore"
validRowFlag = False
Exit For
End Select
Case "to", "cc", "bcc"
If InStr(1, df.Value, "#", vbTextCompare) > 0 Then
validRowFlag = True
End If
End Select
Next
If validRowFlag Then
recordCount = recordCount + 1
End If
If mm.DataSource.ActiveRecord = lastRecordNum Then
Exit Do
Else
mm.DataSource.ActiveRecord = wdNextRecord
End If
Loop
Else
recordCount = lastRecordNum
End If
If recordCount = 0 Then
If MsgBox("Cannot find any active / valid / not to be ignored records. Macro will Exit", vbOKOnly + vbCritical, "Error") = vbOK Then Exit Sub
End If
' Give the user an opportunity to abort, and also the option to save the emails in drafts, or send immediately
Select Case MsgBox("MailMerge to email will proceed for " & IIf(recordCount < 50, recordCount & " active", recordCount) & " records." _
+ Chr(10) + Chr(10) + _
"Click 'OK' to save the emails in draft and 'Cancel' to abort.", _
vbOKCancel + vbDefaultButton2 + vbQuestion, "Send Emails")
Case vbCancel
Exit Sub
Case vbOK
sendFlag = False
End Select
' set variables
' outlookApp is used to control outlook to send an email
' fso is used to read the HTML file with the email content
Set outlookApp = New Outlook.Application
Set fso = New FileSystemObject
' we need to use a temporary file to store the html generated by mail merge
' fso.GetTempName creates a name with the extension tmp. We remove this
' because image files are stored in a folder with the name without the extension and with "_files" at the end
tempFileName = Replace(fso.GetTempName, ".tmp", "")
mm.DataSource.ActiveRecord = wdFirstRecord
recordCount = 0
' loop through all the records
Do While lastRecordNum > 0
' run through the fields to check if a valid email address is provided in any of the "to", "cc" or "bcc" fields (valid address = contains an "#")
' also detect if the row is marked to be ignored
validRowFlag = False
For Each df In mm.DataSource.DataFields
' clean up the provided field name by running through the name letter by letter and adding only letters to the variable fieldName
fieldName = ""
For i = 1 To Len(df.Name)
Select Case Asc(LCase(Mid(df.Name, i, 1)))
Case 97 To 122
fieldName = fieldName & LCase(Mid(df.Name, i, 1))
End Select
Next i
Select Case fieldName
Case "ignore"
Select Case LCase(df.Value)
Case "true", "yes", "y", "ignore"
validRowFlag = False
Exit For
End Select
Case "to", "cc", "bcc"
If InStr(1, df.Value, "#", vbTextCompare) > 0 Then
validRowFlag = True
End If
End Select
Next
' only create an email if there is a valid addressa and the row is not marked as to be ignored
If validRowFlag Then
' use mailmerge to create a new document for one record (defined by mm.DataSource.ActiveRecord)
mm.Destination = wdSendToNewDocument
mm.DataSource.FirstRecord = mm.DataSource.ActiveRecord
mm.DataSource.LastRecord = mm.DataSource.ActiveRecord
mm.Execute Pause:=False
' save the generated doc as a html file in the temp directory
Set singleDoc = ActiveDocument
singleDoc.SaveAs2 FileName:=Environ("Temp") & Application.PathSeparator & tempFileName & ".tmp", FileFormat:=wdFormatFilteredHTML
singleDoc.Close SaveChanges:=wdDoNotSaveChanges
Set singleDoc = Nothing
' read the html from the temp directory using fso
mailBody = fso.OpenTextFile(Environ("Temp") & Application.PathSeparator & tempFileName & ".tmp", 1).ReadAll
' create a new email message in outlook
Set outlookMail = outlookApp.CreateItem(olMailItem)
' display the email so that any images display correctly
outlookMail.Display
' clear the content of the email and remove all attachments (i.e. clear the signature and any images in the signature)
outlookMail.HTMLBody = ""
Do While outlookMail.Attachments.Count > 0
outlookMail.Attachments.Remove 1
Loop
' ensure formatting is HTML
outlookMail.BodyFormat = olFormatHTML
' if the html contains images, then they will be stored in a directory called
' tempFileName followed by the _files in the local language (e.g. _bestanden in Dutch)
' so we need to find the directory, and the loop through each of the files
' checking to see if the files are included in the email as an image (i.e. as 'src="..."')
' if the image is included then the image is attached to the email as a hidden attachment
' and the image path is updated to point to the attached image
' try and find the temporary folder name which would contain any images
tempFolderName = ""
For Each f In fso.GetFolder(Environ("Temp")).SubFolders
If Left(f.Name, Len(tempFileName) + 1) = tempFileName & "_" Then
tempFolderName = f.Name
Exit For
End If
Next
' if the folder has been found, iterate through the files
If tempFolderName <> "" Then
For Each attachFile In fso.GetFolder(Environ("Temp") & Application.PathSeparator & tempFolderName).Files
If InStr(1, mailBody, "src=""" & tempFolderName & "/" & attachFile.Name & """", vbBinaryCompare) > 0 Then
outlookMail.Attachments.Add attachFile.Path, 1, 0
mailBody = Replace(mailBody, "src=""" & tempFolderName & "/" & attachFile.Name & """", "src=""cid:" & attachFile.Name & """")
End If
Next
End If
' add the mail body from the html created via mailmerge and updated for the newly attached images
outlookMail.HTMLBody = mailBody
' run through all the fields in the mail merge data, when an email field is identified add the data to the appropriate field
For Each df In mm.DataSource.DataFields
' first check for the field being populated for the active record (row), only check if there is data provided
If Trim(df.Value) <> "" Then
' try matching the field name to accepted field names
' the field name is cleaned up by running through the name letter by letter and adding only letters to the variable fieldName
fieldName = ""
For i = 1 To Len(df.Name)
Select Case Asc(LCase(Mid(df.Name, i, 1)))
Case 97 To 122
fieldName = fieldName & LCase(Mid(df.Name, i, 1))
End Select
Next i
Select Case fieldName
Case "to"
' add in the to address or addresses as they are presented in the data, multiple address should be separated by a semicolon
outlookMail.To = outlookMail.To & ";" & df.Value
Case "cc"
' add in the cc address or addresses as they are presented in the data, multiple address should be separated by a semicolon
outlookMail.CC = outlookMail.CC & ";" & df.Value
Case "bcc"
' add in the bcc address or addresses as they are presented in the data, multiple address should be separated by a semicolon
outlookMail.BCC = outlookMail.BCC & ";" & df.Value
Case "subject"
' add in the subject as it is presented in the data
outlookMail.Subject = df.Value
Case "importance"
' change the importance, accepted input values are "high", "normal", and "low" (not case sensitive)
' if field is not provided, or an incorrect input value is provided, then the default is used
' default is typically "Normal", but may have been changed in Outlook Options.
Select Case Trim(LCase(df.Value))
Case "high"
outlookMail.Importance = olImportanceHigh
Case "normal"
outlookMail.Importance = olImportanceNormal
Case "low"
outlookMail.Importance = olImportanceLow
End Select
Case "sensitivity"
' change the sensitivity, accepted input values are "confidential", "personal", "private", or "normal" (not case sensitive)
' if field is not provided, or an incorrect input value is provided, then the default is used
' default is typically "Normal", but may have been changed in Outlook Options.
Select Case Trim(LCase(df.Value))
Case "confidential"
outlookMail.Sensitivity = olConfidential
Case "personal"
outlookMail.Sensitivity = olPersonal
Case "private"
outlookMail.Sensitivity = olPrivate
Case "normal"
outlookMail.Sensitivity = olNormal
End Select
Case "readreceipt"
' request or do not request a read receipt
' if the field contains a boolean TRUE, or any form of "true"/"yes"/"y" (case insensitive) then request a read receipt
' if the field contains a boolean FALSE, or any form of "false"/"no"/"n" (case insensitive) then do not request a read receipt
' if field is not provided, or an incorrect input value is provided, then the default is used
' default is typically to not request a read receipt, but may have been changed in Outlook Options.
Select Case Trim(LCase(df.Value))
Case "true", "yes", "y"
outlookMail.ReadReceiptRequested = True
Case "false", "no", "n"
outlookMail.ReadReceiptRequested = False
End Select
Case "deliveryreceipt"
' request or do not request a delivery report
' if the field contains a boolean TRUE, or any form of "true"/"yes"/"y" (case insensitive) then request a delivery report
' if the field contains a boolean FALSE, or any form of "false"/"no"/"n" (case insensitive) then do not request a delivery report
' if field is not provided, or an incorrect input value is provided, then the default is used
' default is typically to not request a delivery report, but may have been changed in Outlook Options.
Select Case Trim(LCase(df.Value))
Case "true", "yes", "y"
outlookMail.OriginatorDeliveryReportRequested = True
Case "false", "no", "n"
outlookMail.OriginatorDeliveryReportRequested = False
End Select
Case "deliverytime"
' add in a delivery time (delay delivery)
' checks for the field containin a value or something which looks like a date and/or time
' if a datetime is provided, and that datetime is in the future then the delay is added to that datetime
' if a date is provided, and that date is in the future then the delay is added to midnight at the start of the provided date
' if a time is provided then the next instance of that time will be used to define the delay (so email could be sent "tomorrow" if time already passed)
' if no data, invalid data, or a date/datetime in the past is added then no delivery delay is added
If (IsNumeric(df.Value) Or IsDate(df.Value)) Then
' A date passed from an Excel table through mail merge will be formatted in US format ("m/d/yyyy"), but the function CDate
' uses the local format, e.g. ("d/m/yyyy"). CDate is nice enough to recognise (and not error) when fed a date with the day > 12,
' so both "15/1/2021" and "1/15/2021" will produce the correct date output (15 January 2021).
' The next couple of lines test for whether the date is the wrong way round and flips the month and day if needed
' A date is believed to be wrong if both month and day are 12 or lower, if CDate parses the date 1/2/2020 as 1 February 2020
' and finally if the raw input from Excel is a date string (and not a number, which would be valid)
inputDate = CDate(df.Value)
If Day(inputDate) <= 12 And Month(inputDate) <= 12 And Month(CDate("1/2/2020")) = 2 And _
InStr(1, df.Value, Format(inputDate, "d/m/yyyy")) = 1 Then
inputDate = DateSerial(Year(inputDate), Day(inputDate), Month(inputDate)) + TimeSerial(Hour(inputDate), Minute(inputDate), Second(inputDate))
End If
If inputDate < Now() - Date Then ' time only, time is in the past so set time for "tomorrow"
outlookMail.DeferredDeliveryTime = Date + 1 + inputDate
ElseIf inputDate < 1 Then ' time only, time is in the future so set time for "today"
outlookMail.DeferredDeliveryTime = Date + inputDate
ElseIf inputDate > Now() Then ' date or datetime in the future
outlookMail.DeferredDeliveryTime = inputDate
End If
Debug.Print df.Value, outlookMail.DeferredDeliveryTime
End If
Case "account"
' select the account from which the email is to be sent
' the account is identified by its full email address
' to identify the account, the code cycles through all the accounts available and selects a match
' if no data, or a non-matching email address is provided, then the default account is used
' note! not the same as send as - see below
For Each outlookAccount In outlookApp.Session.Accounts
If outlookAccount.SmtpAddress = df.Value Then
outlookMail.SendUsingAccount = outlookAccount
Exit For
End If
Next
Case "sendas"
' add in an address to send as or send on behalf of
' only added if a valid email address
' if the account does not have permissions, the email will be created but will be rejected by the Exchange server if sent
If InStr(1, df.Value, "#", vbTextCompare) > 0 Then outlookMail.SentOnBehalfOfName = df.Value
Case "replyto"
' add in an address to reply to
' only added if a valid email address
If InStr(1, df.Value, "#", vbTextCompare) > 0 Then outlookMail.ReplyRecipients.Add (df.Value)
Case "attachment"
' add the attachment
outlookMail.Attachments.Add df.Value
End Select ' end test for the field names
End If ' end check for the data value being blank
Next df ' move on to the next record
' check the send flag and send or save
If sendFlag Then
outlookMail.Send
Else
outlookMail.Close (olSave)
End If
Set outlookMail = Nothing
Else
recordCount = recordCount + 1 ' keep a tally of skipped records using recordCount
End If ' end the test for whether a valid address is presented in the data
' test if we have just created a document for the last record, if so we set lastRecordNum to zero to indicate that the loop should end, otherwise go to the next active record
If mm.DataSource.ActiveRecord >= lastRecordNum Then
lastRecordNum = 0
Else
mm.DataSource.ActiveRecord = wdNextRecord
End If
Loop
End Sub
In the code you display an item in the inspector window:
outlookMail.Display
But in the end the item is sent or closed:
' check the send flag and send or save
If sendFlag Then
outlookMail.Send
Else
outlookMail.Close (olSave)
End If
There is no need to open an inspector window if you are not going to left it for editing by the user in Outlook.
I'd recommend debugging the code going line-by-line and seeing intermediate results.
I'm writing some code to save Outlook emails and I need to know the number of attachments. To get an attachment count have this code. When there are no attachments nAttach is 0 as expected but when there are n attachments I get n+1. I tried using nAttach -1 to correct it but then it bumped up again or sometimes if i have 1 attachment it would come out to 0.
Dim oMail As Outlook.MailItem
Dim sAttach As String
Dim nAttach As Integer
nAttach = oMail.Attachments.Count
If nAttach > 0 Then nAttach = nAttach - 1
sAttach = CStr(nAttach)
The attachment count is most likely right. Note that embedded HTML images can be attachments even if Outlook does not show them in the list of attachments.
I can read code, and adjust code a bit.
I've got access to a company email (say invoice#rr.com).
I want code which looks through all new mail in the inbox of invoice#rr.com (best if this works even when Outlook is not open, but a manually clicked macro would make me happy) and reply to all (with attachment) when:
there is more then one attachment (exception is one .xml and one .pdf file)
the attachment is not .pdf, .xml or .icf
when there is no attachment at all
when the title has the word "reminder"
when the message has the word "reminder"
Besides that, the code needs to move the mail to a subfolder called "send back".
I've been reading forums and one of the problems is a picture in a signature also counts as an attachment.
First try after help from Tony:
Sub reply()
'still need to get rid of all the stuff i dont use below (up to the *) but still not sure about the code so I left it here for now
Dim olInspector As Outlook.Inspector
Dim olDocument As Outlook.DocumentItem
Dim olSelection As Outlook.Selection
Dim olReply As MailItem
Dim olAtt As Attachment
Dim olFileType As String
Dim AttachCount As Long
Dim AttachDtl() As String
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim FolderTgt As MAPIFolder
Dim HtmlBody As String
Dim InterestingItem As Boolean
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim PathName As String
Dim ReceivedTime As Date
Dim RowCrnt As Long
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String
Dim TextBody As String
Dim myDestFolder As Outlook.Folder
'*
Set myDestFolder = Session.Folders("Outlook Data File").Folders("replied")
Set Myselect = Outlook.ActiveExplorer.Selection '(i use this in my test to only process selected test mails)
'Set FolderTgt = Session.Folders("invoice#rr.com").Folders("Inbox") ***(this will replace the code above)
For InxItemCrnt = Myselect.Items.Count To 1 Step -1 '(myselect = foldertgt in live)
With Myselect.Items.Item(InxItemCrnt) '(myselect = foldertgt in live)
'still need a workaround for mail with (1 .PDF and 1 .ICF) or (1 .PDF and 1 .XML)
'those combinations are the only combinations when more then one attachment is allowed
'1st filter
If AttachCount = 0 Then 'no attachment = reply
Reply0
.move myDestFolder
Else
'2nd filter
If AttachCount > 1 Then 'more then one attachment = reply
Reply1
.move myDestFolder
Else
'3rd filter
If InStr(Subject, "Reminder") = 0 Then 'reminders need to go to a different mailbox
Reply2
.move myDestFolder
Else
'4th filter
Select Case olFileType
Case ".pdf, .icf, .xml"
If olFileType = LCase$(Right$(olAtt.FileName, 4)) Then
Exit Sub 'if attachment = pdf or ICF then this sub can exit
Else
Reply3 'all mails with incorrect files
.move myDestFolder
End Select
End If
End If
End If
End If
End With
'replies below
Reply0:
Set olReply = Item.Reply '// Reply if no attachment found
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply1:
Set olReply = Item.Reply '// Reply more then one attachment
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply2:
Set olReply = Item.Reply '// Reply reminders need to go to reminder#rr.com
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply3:
Set olReply = Item.Reply '// Reply not correct file
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Next
Set olInspector = Nothing
Set olDocument = Nothing
Set olSelection = Nothing
Set olAtt = Nothing
End Sub
2nd try after some more help from Tony: (note: I'm Dutch so some code has dutch words I'll explain them in English behind the code, it basicly is copy paste from his answer, all credits to Tony)
Sub reply()
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim FldrInvInbox As MAPIFolder
Dim InxA As Long
Dim InxItemCrnt As Long
Dim NumIcfAttach As Long
Dim NumPdfAttach As Long
Dim NumXmlAttach As Long
Dim NumDocAttach As Long
Dim NumDoxAttach As Long
Dim PathDiag As String
Dim Pos As Long
Dim ProcessThisEmail As Boolean
Dim Subject As String
Dim ReminderInBody As Boolean
Dim ReminderInSubject As Boolean
Dim ReminderInBody1 As Boolean
Dim ReminderInSubject1 As Boolean
Set FldrInvInbox = Session.Folders("invoice#rr.com").Folders("Postvak IN") 'Postvak IN = Inbox)
PathDiag = "z:\VBA test" 'location for diagnostics report
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1
With FldrInvInbox.Items.Item(InxItemCrnt)
' It is unlikely an Inbox will contain anything but emails
' but it does no harm to check
If .Class = olMail Then
' Extract information that will identify if this email is to be processed
ProcessThisEmail = True ' Assume True until find otherwise
'Below i'm looking for reminder, payment reminder and other similiar text in subject, dutch words are betalingsherinnering and openstaande posten
If InStr(1, LCase(.Subject), "betalingsherinnering") = 0 Then
ReminderInSubject = False
Else
ReminderInSubject = True
ProcessThisEmail = False
End If
If InStr(1, LCase(.Subject), "openstaande posten") = 0 Then
ReminderInSubject1 = False
Else
ReminderInSubject1 = True
ProcessThisEmail = False
End If
'Below i'm looking for reminder, payment reminder and other similiar text in mail, dutch words are betalingsherinnering and openstaande posten
If InStr(1, LCase(.Body), "betalingsherinnering") = 0 Then
ReminderInBody = False
Else
ReminderInBody = True
ProcessThisEmail = False
End If
If InStr(1, LCase(.Body), "openstaande posten") = 0 Then
ReminderInBody1 = False
Else
ReminderInBody1 = True
ProcessThisEmail = False
End If
NumIcfAttach = 0
NumPdfAttach = 0
NumXmlAttach = 0
NumDocAttach = 0
For InxA = 1 To .Attachments.Count
Select Case LCase(Right$(.Attachments(InxA).FileName, "3"))
Case "txt"
NumIcfAttach = NumIcfAttach + 1 'code will be changed soon, need to look at ICF in the name of the attachment
Case "pdf"
NumPdfAttach = NumPdfAttach + 1
Case "doc"
NumDocAttach = NumDocAttach + 1
Case "xml"
NumXmlAttach = NumXmlAttach + 1
End Select
Next InxA
Else ' Not email
ProcessThisEmail = False
End If
End With
' Decide if email is to be processed
If ProcessThisEmail = True Then
If NumXmlAttach > 1 Then
ProcessThisEmail = False
Else
If NumDocAttach <> 0 Then
ProcessThisEmail = False
Else
If NumPdfAttach > 1 Then
ProcessThisEmail = False
Else
If NumIcfAttach > 1 Then
ProcessThisEmail = False
Else
If NumIcfAttach + NumPdfAttach = 2 Then
ProcessThisEmail = True
Else
If NumXmlAttach + NumPdfAttach = 2 Then
ProcessThisEmail = True
Else
If NumXmlAttach = 1 And NumIcfAttach = 0 And NumPdfAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumPdfAttach = 1 And NumIcfAttach = 0 And NumXmlAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumIcfAttach = 1 And NumXmlAttach = 0 And NumPdfAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumXmlAttach + NumPdfAttach + NumIcfAttach = 0 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumIcfAttach = 2 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumPdfAttach + NumIcfAttach = 3 Then
ProcessThisEmail = False
Else
If NumIcfAttach + NumPdfAttach <> 2 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumPdfAttach <> 2 Then
ProcessThisEmail = False
Else
Procisthisemail = False
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
' Output diagnostic information
DiagFile.WriteLine "----- " & InxItemCrnt & " -----"
With FldrInvInbox.Items.Item(InxItemCrnt)
DiagFile.WriteLine "ReceivedTime=" & .ReceivedTime
DiagFile.WriteLine "Sender=" & .Sender
Subject = .Subject
For Pos = Len(Subject) To 1 Step -1
If AscW(Mid(Subject, Pos, 1)) < 1 Or _
AscW(Mid(Subject, Pos, 1)) > 255 Then
Subject = Replace(Subject, Mid(Subject, Pos, 1), "?")
End If
Next
DiagFile.WriteLine "Subject=" & Subject
DiagFile.WriteLine "Reminders: Subject 1=" & ReminderInSubject & _
" Subject 2=" & ReminderInSubject1 & _
" Body 1=" & ReminderInBody & _
" Body 2=" & ReminderInBody1
DiagFile.WriteLine "Attachment counts: ICF=" & NumIcfAttach & _
" PDF=" & NumPdfAttach & " XML=" & NumXmlAttach & _
" Doc=" & NumDocAttach
DiagFile.WriteLine "ProcessThisEmail=" & ProcessThisEmail
End With
' Process email if required
If ProcessThisEmail Then
End If
Next InxItemCrnt
DiagFile.Close
End Sub
My first reaction is: there is way too much untested code in your revised question. I plan to review your code but most of this answer is a tutorial explaining how I would have tackled your requirement.
None of us were born with the knowledge to write the macro you need. I started with Excel VBA which I believe was lucky since the training material for Excel VBA is much better than that for Outlook VBA. I visited a good library and borrowed several “Teach yourself to program Excel” books. I tried them all and then bought the one that was best for my learning style. I would recommend you invest a few days learning Excel VBA. I am confident that this investment will quickly repay itself. I did buy a highly recommended Outlook VBA but was not impressed. The transition from Excel to Outlook was not as easy as it could have been because I have never found a good explanation of the Outlook Object Model. Most of my knowledge is the result of much experimentation over many years. This background means I can usually look at some badly explained Outlook property and be able to deduce what they meant to say.
One of my advantages is that I have spent time studying development and testing theory. There is little in your code that is wrong but I believe a different approach would produce the desired result more quickly.
Another advantage which I would recommend to you is a folder on my system named “Resources” with sub-folders by topic. Every time I complete a development, I look through the code for ideas I might need again. I capture each idea in a file in the appropriate sub-folder with sample code, references to the source and notes on anything I found difficult. I don’t use VBA often enough to remember everything I have learnt. Being able to look for relevant files when starting a new development saves me a lot of time.
That’s enough general points. From your original question, I think you need the following for your requirement:
To read up or down the Inbox of invoice#rr.com.
To identify the number of attachments of an email and, if any, their extensions.
To check if the title of an email includes "remainder".
To check if body of an email includes "remainder".
To reply to selected emails
To move selected emails to folder “send back”
Your original specification of which emails were to be selected is not clear to me. Your added code is a little clearer but adds the complication that you appear to envisage different replies for different emails.
In your code, you do not read up or down the Inbox of invoice#rr.com. Instead you use Inspector to process selected emails. This would allow you to select an email with no attachments, say, and test how you code handles it. I do not think this is a good idea. For me, reading down the inbox and selecting the emails to be processed is the larger and more complicated block of code. I would want to write and test that code before writing the code to replying or moving emails. I would not want to reply to emails until I knew I had everything else correct. I would not want to move emails to a different folder until near the end of testing because I would not want to move them back for a retest.
The potential problem with my approach is the number of emails in the Inbox of invoice#rr.com. How do I test each email is correctly identified as needing a reply or not needing a reply? VBA comes with some diagnostic aids but one of my favourite technique is to write the envelope for my code but to output diagnostic text identifying the decisions made by the code without acting on those decisions. The code I have written shows what I mean by this.
To output diagnostic text, I can use something like Debug.Print "xxxx=" & xxxx where xxxx is a variable. This outputs to the Immediate Window which is often the most convenient technique. But you can only see the last 200 or so displays with Debug.Print and I suspect this will not be enough. Instead I will output to a text file. I do not do this often enough to remember the syntax so I have a file to remind me. File “Output to diagnostic file.txt” contains:
' Needs reference to Microsoft Scripting Runtime
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim PathDiag As String
PathDiag = ThisWorkbook.Path
PathDiag = CreateObject("WScript.Shell").specialfolders("Desktop")
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
DiagFile.WriteLine ""
DiagFile.Close
I do not need the reminder about “Microsoft Scripting Runtime” for Outlook because I referenced it when I first installed Outlook. You will need to open the Outlook VBA Editor, click Tools and select References from the drop down menu. Scroll down the list of libraries and tick “Microsoft Scripting Runtime”. Without this reference, the compiler will not recognise “FileSystemObject” or “TextStream”. I use the first value for PathDiag if I am working with Excel. Here I will use the second value which will create the file on the desktop.
I have taken code from the answer I referenced in my comment. I renamed some of the variables and simplified the handling of attachments. I inserted code from file “Output to diagnostic file.txt”. I added code to extract the values needed for selecting emails. This code only involves simple (for me) statements that I remember how to use correctly. I added the code to output diagnostics to the text file. Here I hit a problem. Execution stopped on DiagFile.WriteLine “Subject=" & .Subject saying this an invalid call. It took me a while to identify the cause and add code to fix it. I will explain this latter. Here is my code:
Option Explicit
Sub ReplyToInvoiceEmails()
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim FldrInvInbox As MAPIFolder
Dim InxA As Long
Dim InxItemCrnt As Long
Dim NumIcoAttach As Long
Dim NumPdfAttach As Long
Dim NumXmlAttach As Long
Dim PathDiag As String
Dim Pos As Long
Dim ProcessThisEmail As Boolean
Dim Subject As String
Dim ReminderInBody As Boolean
Dim ReminderInSubject As Boolean
Set FldrInvInbox = Session.Folders("tonydallimore23#gmail.com").Folders("Inbox")
PathDiag = CreateObject("WScript.Shell").specialfolders("Desktop")
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1
With FldrInvInbox.Items.Item(InxItemCrnt)
' It is unlikely an Inbox will contain anything but emails
' but it does no harm to check
If .Class = olMail Then
' Extract information that will identify if this email is to be processed
ProcessThisEmail = True ' Assume True until find otherwise
If InStr(1, LCase(.Subject), "reminder") = 0 Then
ReminderInSubject = False
Else
ReminderInSubject = True
End If
If InStr(1, LCase(.Body), "reminder") = 0 Then
ReminderInBody = False
Else
ReminderInBody = True
End If
NumIcoAttach = 0
NumPdfAttach = 0
NumXmlAttach = 0
For InxA = 1 To .Attachments.Count
Select Case LCase(Right$(.Attachments(InxA).Filename, "3"))
Case "ico"
NumIcoAttach = NumIcoAttach + 1
Case "pdf"
NumPdfAttach = NumPdfAttach + 1
Case "xml"
NumXmlAttach = NumXmlAttach + 1
End Select
Next InxA
Else ' Not email
ProcessThisEmail = False
End If
End With
' Decide if email is to be processed
If ProcessThisEmail Then
If ReminderInSubject Or ReminderInBody Then
ProcessThisEmail = False
ElseIf NumXmlAttach = 1 Then
ProcessThisEmail = False
End If
End If
' Output diagnostic information
DiagFile.WriteLine "----- " & InxItemCrnt & " -----"
With FldrInvInbox.Items.Item(InxItemCrnt)
DiagFile.WriteLine "ReceivedTime=" & .ReceivedTime
DiagFile.WriteLine "Sender=" & .Sender
Subject = .Subject
For Pos = Len(Subject) To 1 Step -1
If AscW(Mid(Subject, Pos, 1)) < 1 Or _
AscW(Mid(Subject, Pos, 1)) > 255 Then
Subject = Replace(Subject, Mid(Subject, Pos, 1), "?")
End If
Next
DiagFile.WriteLine "Subject=" & Subject
DiagFile.WriteLine "Reminders: Subject=" & ReminderInSubject & _
" Body=" & ReminderInBody
DiagFile.WriteLine "Attachment counts: ICO=" & NumIcoAttach & _
" PDF=" & NumPdfAttach & " XML=" & NumXmlAttach
DiagFile.WriteLine "ProcessThisEmail=" & ProcessThisEmail
End With
' Process email if required
If ProcessThisEmail Then
End If
Next InxItemCrnt
DiagFile.Close
End Sub
The first executable statement is Set FldrInvInbox = Session.Folders("tonydallimore23#gmail.com").Folders("Inbox"). You must replace "tonydallimore23#gmail.com" with "invoice#rr.com" or the real name for this store. Apart from this change, this code should run without problems on your system.
Next are the statements to prepare the diagnostic text file and then: For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1.
FldrInvInbox.Items is a collection holding all the items in FldrInvInbox. A collection is like an array (if you know what an array is) except you can add items to the middle of a collection and delete items from the middle. FldrInvInbox.Items.Count is the number of items in FldrInvInbox.Items. I am accessing items in this collection by their position. If the code decides item 5 is to be moved to another folder, item 6 become item 5, item 7 becomes item 6 and so on. This would mess up the For-Loop. I am accessing this collection starting from the end. If I move item 1000 to a different folder then items 1 to 999, which I have yet to process, do not move so the For-Loop works properly.
The next block of code extracts properties to variables. I think I have extracted every property you need but you must check. The next block of code decides if an email is to be processed. I like to divide code into blocks like this because it is easier to write and easier to understand if you need to change it in a year’s time. I do not understand how you want to select emails and I am sure my selection code is wrong. You will have to correct this block of code or provide more information on the selection process so I can correct it.
Next is code to create the diagnostic output. On my system, the diagnostic output looks like:
----- 55 -----
ReceivedTime=09/08/2018 13:03:09
Sender=TechTarget Channel Media
Subject=Channel ecosystem sees major shift in partner types
Reminders: Subject=False Body=False
Attachment counts: ICO=0 PDF=0 XML=0
ProcessThisEmail=True
----- 54 -----
ReceivedTime=09/08/2018 11:48:10
Sender=TechTarget
Subject=Industrial control systems a specialised cyber target
Reminders: Subject=False Body=False
Attachment counts: ICO=0 PDF=0 XML=0
ProcessThisEmail=True
----- 53 -----
The first three lines of each email identify the email so you can locate it in the folder. The second three lines are the selection values which I know are wrong.
If I had missed some selection values, you will have to add them. You will have to correct my selection code. You want every “ProcessThisEmail=True/False” line to be correct before we move on to the reply code.
The problem I encountered with the diagnostic code was because of emojis. Execution stopped on the statement outputting the subject for some emails and it took me sometime to locate the cause. The diagnostic file is a simple ASCII text file and an emoji cannot be output to an ASCII text file. I thought of ignoring the problem since you were unlikely to have emojis in your subject. I decided to fix the problem because you have neither the experience to diagnose the problem nor to experience fix it if you did diagnose it. Have a look at my code and try to understand what I have done.
I need you to complete tmy code before we move on to the next section. I will add some text about the next section later but this section is much later than I promised so I will post what I have now.
This next paragraphs are to get you thinking about the email bodies you will create and the ones you have checked for “Reminder”.
An Outlook email can have three bodies: a text body, an Html body and a Rich Text Format (RTF) body. I have never received an email with a RTF body. I have seen a question about them but to my mind they are obsolete; perhaps they were useful before Html became so well known. I will ignore the theoretical existence of RTF bodies. An Outlook email can have a text body, an Html body or both. If there is an Html body, that is the body that is shown to the user. I rarely receive emails without an Html body. The Html bodies I receive vary enormously in both appearance and the Html used to create that appearance. Many are very complicated with style sheets and nested table so the result will look good on a laptop or a smartphone or whatever device the user views it on. I said, an Outlook email can have an Html body without a text body but I cannot find one in my archives for the last few years. I suspect they are being created by Outlook from the Html body by deleting all the Html tags and adding carriage-return-linefeeds to mark deleted paragraphs and table cells.
With an Outlook email, property Body is the text body and property HtmlBody is the Html body. In my code I only check the text body for “Reminder”. This seems sensible since the text body will be a lot smaller and I cannot find an email without a text body. If you want to be ultra-cautious, I will show you how to check the Html body if there is no text body or you might like to consider how to do this as a training exercise.
In your code you have:
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & ".... insert text...."
You might find that the following gives a more attractive appearance since email packages tend to use a more attractive font when displaying Html bodies if none is specified:
olReply.Body = ""
olReply.HtmlBody = "<HTML><BODY>" & _
"<P>this is an automatic generated mail.</P>" & _
"<P>.... insert text....</P>" & _
"</BODY>" & "</HTML>"
This is very basic Html and is now depreciated but it shows an Html body could be created for little more effort than creating a text body. Html also allows formatting (bold, italic, font size, font colour and so on) which might be helpful.
[Hi All I am just new in VBA excel macro and trying to create my own macro. the vb mini-program i have will search for specific value(example. 15) in all the log files in certain directory or location. Once the value was found in the log file, the program will list it in list box. my program is functioning. My only problem is, if theres hundreds or thousands of log files in the location, the program will list all log data with value of 1 or 5 including the log data with the exact value 15. the other problem is that the log data with value of 15 will be listed below which is supposed to be on the top or listed at the first found item which have the correct value. Below are my questions.
Is it possible that if the program found out the log data with exact value, the program will list it on top or can be listed first?
It is more easy also if the output will be limit . Because if there are thousands or hundreds of file with 1 and 5 , everything will be listed in the list box. is it possible to list only the right log data with value of 15? Kindly see below snapshot and code. I am planning to use this macro also in my work the reason why I am trying to figure it out.
Program:
Private Sub Comfind_Click()
Dim theString As String
Dim path As String
Dim StrFile As String
Dim fso As New FileSystemObject
Dim file As TextStream
Dim line As String
Dim blnFound As Boolean
ListLog.Clear
theString = TextPlate.Text
path = TextPath.Text
StrFile = Dir(path & "*.pdms")
Do While StrFile <> ""
'Find TheString in the file
'If found, list log and exit loop
Set file = fso.OpenTextFile(path & StrFile)
Do While Not file.AtEndOfLine
line = file.ReadLine
If InStr(1, line, theString, vbTextCompare) > 0 Then
ListLog.AddItem StrFile
Exit Do
End If
Loop
file.Close
Set file = Nothing
Set fso = Nothing
StrFile = Dir()
Loop
MsgBox "successfully search log data!!!"
End Sub
Log file:
You can narrow it down a bit:
Dim arr
Do While Not file.AtEndOfLine
line = file.ReadLine
If InStr(1, line, "PLATEKEY", vbTextCompare) > 0 Then
arr = Split(line, "PLATEKEY")
If Trim(arr(1)) = theString Then
ListLog.AddItem StrFile
Exit Do
End If
End If
Loop
So here's an interesting problem I stumbled upon on. I’m running into issues by sending emails out to SpiceWorks and Mac users.
When a user has a problem they will email Help Desk. We setup a personal Outlook email to handle Help Desk tickets. Once the ticket hits the outlook mailbox it will automatically be sent to our SpiceWorks site.
Now all of our emails have signatures and there are certain signatures with small png image logos (Youtube, LinkedIn, Facebook, and Twitter).
When the email hits SpiceWorks it uploads those png images as attachments. These attachments cause most of the problems because some email threads get very long before they even get submitted as an help desk ticket. They would end up with maybe 20+ attachments of the same four logo png's.
I coded to remove all attachments to that specific address but some users send actual attachments. I tried remove the specific attachments by name but if there are duplicates of same .png image they would just iterate. (img001 through img004 is now img005 through img009)
I found the current VBA script in the HelpDesk Outlook. I was told that Outlook has to be running all the time in order for it to work... sometimes.
I started writing my own script where it checks if the current email is going to HelpDesk email address then remove the attachemnts. No luck yet.
Current Code
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim str As String
Dim emailAddress As String
Dim prompt As String
Dim msgbody As String
msgbody = Item.Body
Set msg = Item 'Subject Message
Set recips = msg.Recipients
str = "HelpDesk"
For x = 1 To GetRecipientsCount(recips)
str1 = recips(x)
If str1 = str Then
'MsgBox str1, vbOKOnly, str1 'For Testing
prompt = "Are you sure you want to send to " & str1 & "?" 'For Testing
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 'For Testing
Cancel = True
End If
'if attachments are there
If Item.Attachments.Count > 0 Then
'for all attachments
For i = Item.Attachments.Count To 1 Step -1
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
MsgBox ("Item Removed " + Item.Attachments(i))
Item.Attachments.Remove (i)
End If
Next
End If
End If
Next x
End Sub
Public Function GetRecipientsCount(Itm As Variant) As Long
' pass in a qualifying item, or a Recipients Collection
Dim obj As Object
Dim recips As Outlook.Recipients
Dim types() As String
types = Split("MailItem, AppointmentItem, JournalItem, MeetingItem, TaskItem", ",")
Select Case True
' these items have a Recipients collection
Case UBound(Filter(types, TypeName(Itm))) > -1
Set obj = Itm
Set recips = obj.Recipients
Case TypeName(Itm) = "Recipients"
Set recips = Itm
End Select
GetRecipientsCount = recips.Count
End Function
A few questions:
1.) Is there a way to set rules in outlook(Looked at numerous possibilities) or do something with the Exchange Server to stop this from happening?
2.) With Vba is there a way to remove or not allow a signature when the email is sent?
If anything, my ultimate goal is just to prevent those .png's being uploaded as images to Mac users and SpiceWorks.
I'm sure there is more to this but I will gladly answer any questions given to me.
Thank you for any help or directions!
If I understand you correctly, you're trying to remove .png files being sent to SpiceWorks. If so, use the macro below from the Outlook mailbox sending to SpiceWorks. On the ItemSend event, this will check the filename of all attachments and remove those with .png extensions. If this is not what you're trying to do, post back here. Thanks.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if the attachment's extension is .png, remove
If Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
Next
End If
End Sub
----- updated to only remove attachments that look like "image###.png" -----
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
Next
End If
End Sub
----- updated to only remove attachments that are <10kb and look like "image###.png"-----
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if attachment size is less than 10kb
If Item.Attachments(i).Size < 10000 Then
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
End If
Next
End If
End Sub