Outlook VBA邮件转约会：图片无法保留的技术问题

我需要批量创建约会，于是编写了Outlook VBA代码，从确认邮件中提取信息生成约会。最初的版本将所有内容转为纯文本，未保留邮件正文图片；修改后的版本虽不再转换图片，但仍无法提取邮件正文中的图片。

初始版本代码 #

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

修改后版本代码 #

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

问题原因 #

你的代码始终使用.Body属性获取邮件内容，这个属性仅返回纯文本格式数据，完全忽略邮件中的富文本元素（包括图片）。要保留图片及其他富文本格式，必须使用.HTMLBody属性，同时需将约会的内容格式设置为HTML。

修复后的核心修改 #

在CreateAppointment过程的With Appt代码块中，替换原有的.Body赋值逻辑：

With Appt
    .BodyFormat = olFormatHTML ' 将约会内容格式设为HTML
    .HTMLBody = eBody.HTMLBody ' 复制邮件的HTML内容（包含图片）
    ' 以下原有代码保持不变
    .Attachments.Add eMail
    .Subject = SMBName
    .Categories = "Appointments"
    .Start = ApptDateTime
    .Duration = 45
    .Display
    .Move fldFolder
End With

补充说明 #

• 邮件中的内嵌图片通过HTML代码引用邮件附件资源，直接复制HTMLBody即可自动保留图片显示，无需单独提取图片添加到约会。
• 若邮件图片为外部网络链接，需确保约会打开时设备能访问对应网络地址，否则图片无法正常显示。

内容的提问来源于stack exchange，提问作者Ameera Cheeks