I'm about to book a lot of appointments, so I made Outlook VBA code to pick out the info in the confirmation emails and make an appointment.
The problem is that instead of copying the email body with pictures, it is converting everything to text.
Public WithEvents olItems As Outlook.items
Public Sub Application_Startup()
Dim olApp As Outlook.Application, olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).items
Debug.Print "Application_Startup triggered " & Now()
End Sub
Public Sub CreateAppointment()
'Creates an appointment, inserts the open email as an attachment and as text, and sets appointment date and time.
Dim eBody As Object, eName As Variant, eSched As Variant, eDate As Variant, eTime As Variant
Dim MonthName As Variant, MonthNumber As Variant
Dim SMBName As Variant, ApptDateTime As Variant
Dim i As Variant, c As Variant
Dim eMail As Object, eMail2 As Object
Dim Appt As AppointmentItem, fldFolder As Folder, myItem As Object
Dim Ns As NameSpace
Set eMail = GetCurrentItem()
Set eBody = eMail
eName = eMail.Body
i = InStrRev(eName, "An appointment is coming up with ", -1) + 33
c = InStrRev(eName, ", name", -1)
SMBName = Mid(eName, i, c - i)
i = InStrRev(eName, " on ", c + 100) + 4
c = InStrRev(eName, Chr(40), -1) - 3
eSched = Mid(eName, i, c - i)
i = InStrRev(eSched, " at", -1) - 4
c = Mid(eSched, i + 2, 2)
MonthName = Mid(eSched, 1, i)
eDate = DateValue(MonthName & " " & c & " " & Year(Date))
i = InStrRev(eSched, Chr(58), -1) - 2
eTime = Mid(eSched, i, 5) & ":00 " & Mid(eSched, i + 6, 2)
eTime = TimeValue(eTime) + TimeSerial(2, 0, 0)
ApptDateTime = eDate + eTime
Set Ns = Application.GetNamespace("MAPI")
Set fldFolder = Ns.GetDefaultFolder(olFolderCalendar)
Set item = GetObject(, "Outlook.Application")
Set Appt = Application.CreateItem(olAppointmentItem)
With Appt
.Body = eBody.Body
.Attachments.Add eMail
.Subject = SMBName
.Categories = "Appointments"
.Start = ApptDateTime
.Duration = 45
End With
Appt.Move fldFolder
' eMail2.Delete
eMail.Close olDiscard
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
'Private Sub olItems_ItemAdd(ByVal item As Object)
'Dim my_olMail As Outlook.MailItem
'If TypeName(item) = "MailItem" Then
' If Subject(item) = "A Client Has Scheduled An Appointment" Then
' 'item.Open
' Call CreateAppointment
' 'item.Close
' Set my_olMail = item
'
' Debug.Print my_olMail.Subject
' Debug.Print my_olMail.SenderEmailAddress
'
' Set my_olMail = Nothing
'End If
'End Sub
I'm still not getting the images out of the email body, but it is not translating those images anymore. Here is the version I'm going with.
Public WithEvents olItems As Outlook.items
Public Sub Application_Startup()
Dim olApp As Outlook.Application, olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).items
'Debug.Print "Application_Startup triggered " & Now()
End Sub
Public Sub olItems_ItemAdd(ByVal item As Object)
Dim my_olMail As Outlook.MailItem
If TypeName(item) = "MailItem" Then
If item.Subject = "A Client Has Scheduled An Appointment" Then
Set my_olMail = item
my_olMail.Display
Call CreateAppointment
End If
' Debug.Print my_olMail.Subject
' Debug.Print my_olMail.SenderEmailAddress
Set my_olMail = Nothing
End If
End Sub
Public Sub CreateAppointment()
'Creates an appointment, inserts the open email as an attachment and as text, and sets appointment date and time.
Dim eBody As Object, eName As Variant, eSched As Variant, eDate As Variant, eTime As Variant
Dim MonthName As Variant, MonthNumber As Variant
Dim SMBName As Variant, ApptDateTime As Variant
Dim i As Variant, c As Variant
Dim eMail As MailItem, eMail2 As Object
Dim Appt As AppointmentItem, fldFolder As Folder, item As Object
Dim Ns As NameSpace
Set eMail = Application.ActiveInspector.CurrentItem
Set eBody = eMail
eName = eMail.Body
i = InStrRev(eName, "An appointment is coming up with ", -1) + 33
c = InStrRev(eName, ", name", -1)
SMBName = Mid(eName, i, c - i)
i = InStrRev(eName, " on ", c + 100) + 4
c = InStrRev(eName, Chr(40), -1) - 3
eSched = Mid(eName, i, c - i)
i = InStrRev(eSched, " at", -1) - 4
c = Mid(eSched, i + 2, 2)
MonthName = Mid(eSched, 1, i)
eDate = DateValue(MonthName & " " & c & " " & Year(Date))
i = InStrRev(eSched, Chr(58), -1) - 2
eTime = Mid(eSched, i, 5) & ":00 " & Mid(eSched, i + 6, 2)
eTime = TimeValue(eTime) + TimeSerial(2, 0, 0)
ApptDateTime = eDate + eTime
Set Ns = Application.GetNamespace("MAPI")
Set fldFolder = Ns.GetDefaultFolder(olFolderCalendar)
Set item = GetObject(, "Outlook.Application")
Set Appt = Application.CreateItem(olAppointmentItem)
With Appt
.Body = eBody.Body
.Attachments.Add eMail
.Subject = SMBName
.Categories = "Appointments"
.Start = ApptDateTime
.Duration = 45
.Display
.Move fldFolder
End With
eMail.Close olDiscard
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
The ApppointmentItem object does not expose the HTMLBody property. In the code you are dealing with the Body property which is a plain text string and can't contain any images:
With Appt
.Body = eBody.Body
If you need to have any formatting you can set the RTFBody property instead. But even in case of RTF formatted text I think it is very inconvenient to deal with images. You can use the following workarounds:
You can use the Word object model for dealing with item bodies, so you can paste the HTML markup. See Chapter 17: Working with Item Bodies for more information.
For example, to add a picture to an item currently being displayed:
Application.ActiveInspector.WordEditor.Shapes.AddPicture
Recent Outlook versions (starting from 2016) allow to set a HTML markup as the message body by using a low-level property - PR_HTML (DASL name is http://schemas.microsoft.com/mapi/proptag/0x10130102). In that case you need to add the image as an attachment and set its PR_ATTACH_CONTENT_ID property using Attachment.PropertyAccessor.SetProperty to the cid used by the <img> tag in the HTML body markup.