I have tried to make a script to pick up emails as they come in, reformat them and then forward on to the email in the body but I cannot work out how to read the email body. I currently have:
Sub Confirmation()
myMessage = "You recently made a request on the IT website, the details of your
request can be seen below:" & vbCr & vbCr & "Thank you, " & vbCr & "IT Support"
Dim itmOld As MailItem, itmNew As MailItem
Set itmOld = ActiveInspector.CurrentItem
Set itmNew = itmOld.Forward
itmNew.Body = myMessage & vbCr & vbCr & itmOld.Body
itmNew.Subject = "IT Web Request Confirmation"
itmNew.Display
Set itmOld = Nothing
Set itmNew = Nothing
End Sub
This opens the email adds some text to it and forwards it on.
I would like the script to open the email, read an email address from the body, use that as the to field and reformat the existing email to a nicer format.
This is the HTML from the email:
<html><body><br /><br /><table><tr><td><b>Fullname: </b></td><td>Alex Carter</td></tr><tr><td><b>OPS_Access: </b></td><td>Yes</td></tr><tr><td><b>Email_Account_Required: </b></td><td>Yes</td></tr><tr><td><b>Office_Email_Required: </b></td><td>Yes</td></tr><tr><td><b>Website_Access_Required: </b></td><td>Yes</td></tr><tr><td><b>Web_Access_Level: </b></td><td>Staff</td></tr><tr><td><b>Forum_Access_Required: </b></td><td>Yes</td></tr><tr><td><b>Date_Account_Required: </b></td><td>03/08/2013</td></tr><tr><td><b>Requested_By: </b></td><td>Alex Carter</td></tr><tr><td><b>Requestee_Email: </b></td><td>alex.carter#cars.co.uk</td></tr><tr><td><b>Office_Requesting: </b></td><td>Swindon</td></tr></table></body></html>
This shows that the email to go into the to field is in the 10th row of the table but I am not too sure how to go about selecting this from the body?
How would I go about reading the body, reformatting it and then selecting the requestee email and using it as the to field?
Thanks in advance!
This should help you get started (modifying your code), though you'll have to be more specific with regard to what formatting improvements you would like to see...:
Sub Confirmation()
myMessage = "You recently made a request on the IT website, the details of your request can be seen below:" & vbCr & vbCr & "Thank you, " & vbCr & "IT Support"
Dim sAddress As String ' Well need this to store the address
Dim itmOld As MailItem, itmNew As MailItem
Set itmOld = ActiveInspector.CurrentItem
Set itmNew = itmOld.Forward
sAddress = GetAddressFromMessage(itmOld) ' This is our new function
If Len(sAddress) > 0 Then
itmNew.To = sAddress ' If our new function found a value apply it to the To: field.
'!!! This should be checked as a valid address before continuing !!!
End If
itmNew.Body = myMessage & vbCr & vbCr & itmOld.Body
itmNew.Subject = "IT Web Request Confirmation"
itmNew.Display
Set itmOld = Nothing
Set itmNew = Nothing
End Sub
Private Function GetAddressFromMessage(msg As MailItem) As String
' Grabs the email from the standard HTML form described in the SO question.
Dim lStart As Long
Dim lStop As Long
Dim sItemBody As String
Const sSearchStart As String = "Requestee_Email: </b></td><td>" ' We will look for these tags to determine where the address can be found.
Const sSearchStop As String = "</td>"
sItemBody = msg.HTMLBody ' Read the body of the message as HTML to retain TAG info.
lStart = InStr(sItemBody, sSearchStart) + Len(sSearchStart)
If lStart > 0 Then ' Make sure we found the first TAG.
lStop = InStr(lStart, sItemBody, sSearchStop)
End If
GetAddressFromMessage = vbNullString
If lStop > 0 And lStart > 0 Then ' Make sure we really did find a valid field.
GetAddressFromMessage = Mid(sItemBody, lStart, lStop - lStart)
End If
End Function
Related
I am trying to address a list of clients by their name when I send them meeting invitations. Clients must not see other invitees. I have tried several approaches: add clients one-by-one as a Resource, changing meeting notes text each time, forwarding the meeting as an iCalendar item, no luck.
Objective:
Simulate the Forward behavior of an Outlook Meeting.
Change all attendees from Required to Resource(I can do this)
I have done a lot of research and could not find a way to forward a meeting that simulates the user interface version.
Background information:
I have created a Zoom meetings appointment of which I know the location URL
I can successfully access this appointment as an Outlook.AppointmentItem using Restrict
I cannot add the list of clients directly as Resource because then I cannot customize each invite
I cannot use AppointmentItem.ForwardAsVcal as that forwards the meeting as an attachment and does not occupy calendar space for the client (also I believe it looks unprofessional)
I have failed to use MeetingItem.Forward because my object is an Outlook.AppointmentItem
I have successfully added new clients using Recipients.Add and .Type = olResource
I have successfully modified meeting notes using AppointmentItem.GetInspector().WordEditor.Range.FormattedText but this causes previous invites to be canceled and updates text in the invitation so everyone sees the last invite
Code:
Accessing the item successfully
Private Function getMeeting() As Outlook.AppointmentItem
Dim settingsWS As Worksheet
Set settingsWS = ThisWorkbook.Sheets("Settings")
Dim meetingStart As Date, meetingEnd As Date
meetingStart = settingsWS.Cells(2, 1).Value 'start time
Dim locationString As String
locationString = settingsWS.Cells(2, 2).Value 'location url
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.Items
Dim strRestriction As String
daStart = Format(meetingStart, "mm/dd/yyyy hh:mm AMPM")
daEnd = DateAdd("h", 2, daStart)
daEnd = Format(daEnd, "mm/dd/yyyy hh:mm AMPM")
strRestriction = "[Start] >= '" & daStart & "' AND [End] <= '" & daEnd & "'"
strRestriction = strRestriction & " AND [Location] = '" & locationString & "'"
Set oCalendar = GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items.Restrict(strRestriction)
Set getMeeting = oItems(1)
End Function
My failed forwarding trials:
Private Sub sendInvites(oAppt As Outlook.AppointmentItem)
Dim oMail As Outlook.MailItem, oAtt As Outlook.Recipient, embeddedInvitation As OLEObject
Dim industryWS As Worksheet
Set industryWS = ThisWorkbook.ActiveSheet
Dim attendeeRange As Range
Set attendeeRange = industryWS.Cells(3, 1).CurrentRegion 'list of clients
Dim attendeeCompany As String, attendeeEmail As String
Dim attendeeName As String, attendeePrefix As String
Dim attendeeCount As Long, attendeeIndex As Long
attendeeCount = attendeeRange.Rows.Count - 1
For attendeeIndex = 1 To attendeeCount
attendeeCompany = attendeeRange.Cells(attendeeIndex + 1, 1).Value
attendeeEmail = attendeeRange.Cells(attendeeIndex + 1, 2).Value
attendeeName = attendeeRange.Cells(attendeeIndex + 1, 4).Value
attendeePrefix = attendeeRange.Cells(attendeeIndex + 1, 5).Value
Application.StatusBar = "Sending invites (" & CStr(attendeeIndex) & "/" & CStr(attendeeCount) & ") " & attendeeEmail
Set oMail = Outlook.Application.CreateItem(olMailItem)
'Set oMail = oAppt.ForwardAsVcal
oMail.To = attendeeEmail
oMail.BodyFormat = olFormatHTML
oMail.HTMLBody = getInvitationBody(attendeeName, attendeePrefix) & oMail.HTMLBody 'return invitation mailbody as HTML
'Dim fsd As MeetingItem
'fsd.Forward
'Set oAtt = oAppt.Recipients.Add(attendeeEmail)
'oAtt.Type = olResource
'oAppt.GetInspector().WordEditor.Range.FormattedText.Delete
'oMail.GetInspector().WordEditor.Range.FormattedText.Copy
'oAppt.GetInspector().WordEditor.Range.FormattedText.Paste
'oMail.Close False
'oAppt.ForwardAsVcal
'oAppt.Display
'oAppt.Send
oMail.Send
Application.StatusBar = "Saving invites (" & CStr(attendeeIndex) & "/" & CStr(attendeeCount) & ") " & attendeeEmail
'saveInvite oAppt, industryWS, attendeeRange
DoEvents
Next attendeeIndex
End Sub
I solved it after hours of trying.
My initial instinct was to loop through items in the olFolderCalendar since in the UI we access the meeting forward through the calendar, but objects in the calendar are Outlook.AppointmentItem rather than Outlook.MeetingItem which can be forwarded.
The solution is to send the meeting to yourself (or anyone in your organization) so that a copy of the meeting invitation is in your olFolderSentMail. Items in the olFolderSentMail are Outlook.MeetingItem, which can be forwarded. Unless you send it to someone thou, the meeting will not enter your olFolderSentMail.
We can filter our olFolderSentMail by using Restrict and location (URL) of the meeting. Once we have the Outlook.MeetingItem we can create a new Outlook.MeetingItem by calling MeetingItem.Forward on our existing meeting in our olFolderSentMail. Once we have the new Outlook.MeetingItem we can add clients to it as olResource. This will send a customized, otherwise invisible invitation to the client without notifying other clients.
One point of warning before I end this answer: My first approach was to loop in reverse through my olFolderSentMail so as not to loop over to many items and to save time, however keep in mind that everytime you forward the meeting, the new invitation ends up at the top of the olFolderSentMail, so if in reverse, you will be forwarding the forwarded invitation. When using the Restrict approach, you can simply use the first item, which should be your original invitation to yourself.
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.
I am trying to merge mails by extracting the last message in the a conversation thread. I want to keep the formatting intact so i am trying to get the last message along with the html. I am referencing Microsoft HTML Object Library like this
Dim mi As MailItem
Set mi = ActiveExplorer.Selection.Item(1)
Dim bhtml As HTMLBody
Set bhtml = mi.HTMLBody
This is giving a type mismatch error.
MailItem.HTMLBody property returns a string, not an HTLBody object.
I used Regex to extract the last message from the string returned by oMailitem.body property. Here is the pattern (.*(?=(From:.*\nSent:.*\nTo:))) it is a +ve look ahead i used the first item in match collection and set it in a match object than i extracted the last message like with left function like this lastmessage = Left(oMailItem.body,oMatch.firstindex)
Than i wrapped it up in html like this
Dim vResult, vLine, sResult As String
vResult = Split(lastMessage, vbCrLf)
For Each vLine In vResult
sResult = sResult & "</p><p>" & CStr(vLine)
Next
styledLastMessage = "<p>" & sResult & "</p>"
And finally appended to the mail i wanted to merge it with like this
Dim miBody() As String
miBody = Split(oMailItem.HTMLBody, "<div class=WordSection1>")
miBody(1) = "<p>" & styledLastMessage & "</p>" & "-------" & vbCrLf & miBody(1)
oMailItem.HTMLBody = Join(miBody, "<div class=WordSection1>")
Note: After <div class=WordSection1> the first message begins.
My company uses a single email address for customers to send requests and orders to. we created an Access database that import emails into a table. The table creates it's own unique identifier for each email imported but is not supposed to import an email twice. The system was working as we were only concerned with emails coming into the inbox and didn't need anything more than that.
However we now need to know the "flow", "traffic" and "workload" of the email pool that this account is. The email that comes into the inbox is categorized and then moved to a folder called "my_tasks" and a subfolder the folder named as 1 of the four CSRs to be worked on by a manager. This email is then dealt with and the CSR moves it to a subfolder under another folder called "Completed".
So email comes into Inbox, gets moved to my_tasks\joeblow is dealt with and gets moved to Completed\Canada.
Currently I have code that iterates through the folders and finds each email, grabs the fields we want to store and then inserts them into the table. All of this is done in Access through VBA code.
Private Sub ImportEmailItem(objMailItem As Outlook.MailItem)
On Error GoTo ImportEmailItem_Error
' Set up DAO objects
Dim rstMB As DAO.Recordset
Dim dskippedFolderMailCount As Double
Dim strSQLrMB As String
strSQLrMB = "SELECT * FROM tblMailBox WHERE OLID='" & objMailItem.EntryID & "'"
Set rstMB = CurrentDb.OpenRecordset(strSQLrMB)
With rstMB
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
If .Updatable Then
.Edit
rstMB!Subject = objMailItem.Subject
rstMB!Body = objMailItem.Body
Call subCategory(objMailItem)
rstMB!CSR = IIf(Len(objMailItem.Categories) = 0, "Unassigned", objMailItem.Categories)
rstMB!Importance = objMailItem.Importance
rstMB!Region = objMailItem.Parent
rstMB!DateModified = objMailItem.LastModificationTime
rstMB!FlagCompleted = objMailItem.FlagRequest
rstMB!folder = objMailItem.Parent
rstMB!Path = objMailItem
.Update
End If
.MoveNext
Wend
Else
rstMB.AddNew
rstMB!olid = objMailItem.EntryID
rstMB!ConversationIndex = objMailItem.ConversationIndex
rstMB!ConversationID = objMailItem.ConversationID
rstMB!Conversation = objMailItem.ConversationTopic
rstMB!To = Left(objMailItem.To, 250)
rstMB!CC = Left(objMailItem.CC, 250)
rstMB!Subject = objMailItem.Subject
rstMB!Body = objMailItem.Body
Call subCategory(objMailItem)
rstMB!CSR = IIf(Len(objMailItem.Categories) = 0, "Unassigned", objMailItem.Categories)
rstMB!Importance = objMailItem.Importance
rstMB!From = objMailItem.SenderEmailAddress
rstMB!Region = objMailItem.Parent
rstMB!DateReceived = objMailItem.ReceivedTime
rstMB!DateSent = objMailItem.SentOn
rstMB!DateCreated = objMailItem.CreationTime
rstMB!DateModified = objMailItem.LastModificationTime
rstMB!FlagCompleted = objMailItem.FlagRequest
rstMB!folder = objMailItem.Parent
rstMB.Update
End If
.Close
End With
ImportEmailItem_Exit:
Set rstMB = Nothing
Exit Sub
ImportEmailItem_Error:
Debug.Print Err.Number & " " & Err.Description
Select Case Err.Number
Case 91
Resume Next
Case 3022
Resume Next
Case -2147221233
MsgBox "Customer Care Account Name is incorrect, please enter the Mail box name as seen in your outlook client.", vbOKOnly, "Mail Folder Name Error"
Me.txtMailAccountName.SetFocus
Exit Sub
Case Else
MsgBox "Error #: " & Err.Number & " " & Err.Description '& Chr(13) + Chr(10) & IIf(mail.Subject Is Null, "", mail.Subject) & " " & IIf(mail.ReceivedTime Is Null, "", mail.ReceivedTime)
' DoCmd.RunSQL "INSERT INTO tblImportReport(ImportDate,ImportFolder,ImportResult,ImportEmailCount) VALUES (#" & Now() & "#,'" & mailFolder & "', 'Error " & Err.Number & "', " & dMailCount & ")"
Resume Next 'cmdImportEmail_Exit
End Select
End Sub
Is there a way to uniquely identify an email with a single field no matter whether it has been moved or not?
I have an idea of what I could do to make sure I have the right email and get the original entry in my database. If there was no other way I could concatenate fields together to form a unique field and then get the database table's primary key field value.
You can use the PR_SEARCH_KEY property (DASL name http://schemas.microsoft.com/mapi/proptag/0x300B0102) - it does not change when a message is moved. It can be accessed through MailItem.PropertyAccessor.GetProperty, but unfortunately you cannot use PT_BINARY properties in Items.Find/Restrict.
You can also set your own named property using MailItem.UserProperties.
UPDATE:
For PR_SEARCH_KEY, see https://msdn.microsoft.com/en-us/library/office/cc815908.aspx.
MaillItem.UserProperties can be used from anywhere - Outlook Object Model is Outlook Object Model whether it is used from inside Outlook or externally from Excel. Keep in mind that setting a user property and saving the item will change its last modified date.
If you want to stick to PR_SEARCH_KEY, to be be able to sort on it, you might want to look at Redemption (I am its author) - its RDOFolder.Items.Find / Restrict methods allow PT_BINARY properties in its queries, e.g. "http://schemas.microsoft.com/mapi/proptag/0x300B0102" = '89F75D48972B384EB2C50266D1541099'
Here is VBA code tested in MS Access 2013 to extract the PR_SEARCH_KEY from an Outlook.MailItem and convert to a string:
Public Function strGetMailItemUniqueId( _
olMailItem As Outlook.MailItem _
) As String
Dim PR_SEARCH_KEY As String
PR_SEARCH_KEY = "http://schemas.microsoft.com/mapi/proptag/0x300B0102"
Dim olPA As Outlook.PropertyAccessor
Set olPA = olMailItem.PropertyAccessor
Dim vBinary As Variant
vBinary = olPA.GetProperty(PR_SEARCH_KEY)
strGetMailItemUniqueId = olPA.BinaryToString(vBinary)
End Function
In Microsoft Outlook versions like 2007, 2010, Office 365 etc. there is a property Message-ID in the headers section of the email.
You can use this property to uniquely identify an email.
Our CRM requires a tag to be placed into the subject field of incoming/outgoing e-mail consisting of <TaskID=xxxx> or <TicketID=xxxx> whereby xxxx is a generated number from our CRM.
Does any know if it's possible to create either 1 or 2 Ribbon 'buttons' within Outlook to append this tag to the subject line. Ideally I'd like a dialog box to appear when you click this box so that you can type in the Ticket or Task ID which will then also be appended into the tag as per above.
I gather the first step is quite easy, but not having a great deal of exposure to VB means I'm a bit stuck with a dialog box and then putting the entry into the subject also.
Any help would be very much appreciated...
Select the message and then run this code:
Sub SetSubjectCRM()
On Error GoTo ErrorHandler
Dim obj As Object
Dim msg As Outlook.mailItem
Dim response As Variant
Dim subjectPart As String
Dim tickettype As String
Set obj = ActiveExplorer.Selection.item(1)
If TypeName(obj) = "MailItem" Then
Set msg = ActiveExplorer.Selection.item(1)
End If
With msg
' get CRM number and type
subjectPart = InputBox("What is the CRM number for this email? Enter 'TaskID' or 'TicketID'")
' parse response
response = Split(subjectPart, ",")
subjectPart = response(0)
tickettype = response(1)
.Subject = msg.Subject & " <" & tickettype & "=" & subjectPart & ">"
.Save
End With
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
You need to enter the input as follows:
CRM Number,TaskID/TicketID
Example:
12345,TaskID
or
13245,TicketID
Assign the code to a QAT button like this:
http://www.howto-outlook.com/howto/macrobutton.htm