Question

我是一个完整的VBA菜鸟，我试图创建一个Outlook宏，它将复制电子邮件的正文并在用户转发之前将其放入模板中。

我的问题是，在宏创建的电子邮件中，原始电子邮件正文中的图像变为空白框，其中包含红色X（错误消息：无法显示链接的图像。文件可能已被移动，重命名或删除。验证链接是否指向正确的文件和位置。）。

我意识到我需要将原始图像复制到临时文件夹中，然后将其重新插入我的电子邮件中。以下代码是我的宏到目前为止的样子，它可以将图像复制到临时文件夹，但我不知道如何将这些图像放入最终的电子邮件中。如果有人可以提供一个代码示例，说明如何在最终电子邮件中查找和替换损坏的图像链接与temp文件夹中的图像链接，它将对我有很大帮助。感谢。

更新：我想出了如何将我的临时文件中的图像作为隐藏附件添加到我的电子邮件中（我已在下面更新了我的代码）。我认为问题是HTML图像标记仍然引用旧电子邮件中图像的位置（例如：src =＆＃34; cid：image001.jpg@01D09693.82092260"）。将删除＆＃34; @ 01D09693.82092260＆＃34;使标签从当前附件中获取图像？我该怎么做？

Sub ForwardEmail()

Dim Item As Outlook.MailItem
Dim oForward As Outlook.MailItem
Dim olAttach As Outlook.Attachments
Dim strFileN As String

Set Item = GetCurrentItem
Set oForward = Application.CreateItemFromTemplate("Z:\Template.oft")

strFileN = Dir("K:\Temp\*.*")

    With oForward
        .Subject = Item.Subject
        .HTMLBody = Item.HTMLBody & oForward.HTMLBody

        Do While Len(strFileN) > 0
            .Attachments.Add "K:\Temp\" & strFileN, olByValue, 0
            strFileN = Dir
        Loop

        .Display
        .BodyFormat = olFormatHTML
    End With

    Kill "K:\Temp\*.*"

    Set Item = Nothing
    Set oForward = Nothing

End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String

    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

    strFolderpath = "K:\Temp\"

    Set objAttachments = GetCurrentItem.Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    For i = lngCount To 1 Step -1

    ' Get the file name.
    strFile = objAttachments.Item(i).FileName

    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFile

    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile

    Next i
    End If

    Set objApp = Nothing
    Set objAttachments = Nothing
    Set objSelection = Nothing

End Function

Answer 1

Attachments类的Add方法允许将文件附加到邮件中。

您还需要使用Attachment.PropertyAccessor在附件上设置PR_ATTACH_CONTENT_ID属性（DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F）。请注意，Attachment类的PropertyAccessor属性已添加到Outlook 2007中。

您可能会发现How do I embed image in Outlook Message in VBA?链接很有用。

有关完整的示例代码，请参阅vba email embed image not showing。

Answer 2

我自己解决了这个问题！

我使用RegEx删除有问题的Hex路径，以便将图像链接到当前连接的路径。这需要相当长的时间才能使我的正则表达式正常工作，但这是最终的代码！

Sub ForwardEmail()

Dim Item As Outlook.MailItem
Dim oForward As Outlook.MailItem
Dim olAttach As Outlook.Attachments
Dim strFileN As String
Dim sBadHex As String

Set Item = GetCurrentItem
Set oForward = Application.CreateItemFromTemplate("Z:\Template.oft")

sBadHex = GetBadHex(Item.HTMLBody)
sEmailHTML = Replace(Item.HTMLBody, sBadHex, "")

strFileN = Dir("K:\Temp\*.*")

    With oForward
        .Subject = Item.Subject
        .HTMLBody = sEmailHTML & oForward.HTMLBody
        Do While Len(strFileN) > 0
            .Attachments.Add "K:\Temp\" & strFileN, olByValue, 0
            strFileN = Dir
        Loop
        '.BodyFormat = olFormatHTML <-- I don't think you need this
        .Display
    End With

Kill "K:\Temp\*.*"
Set Item = Nothing
Set oForward = Nothing

End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String

    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

    strFolderpath = "K:\Temp\"

    Set objAttachments = GetCurrentItem.Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    For i = lngCount To 1 Step -1

    ' Get the file name.
    strFile = objAttachments.Item(i).FileName

    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFile

    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile

    Next i
    End If

    Set objApp = Nothing
    Set objAttachments = Nothing
    Set objSelection = Nothing

End Function

Function GetBadHex(sInput As String) As String
 Dim rImgTag As RegExp
 Set rImgTag = New RegExp
 Dim mImgTag As Object
 Dim rBadHex As RegExp
 Set rBadHex = New RegExp
 Dim mBadHex As Object


 Dim sImgTag As String
 Dim sBadHex As String

     With rImgTag
        .Pattern = "cid:image[0-9]{3}\.[a-z]{3}@[0-9A-Z]{8}\.[0-9A-Z]{8}"
     End With

     With rBadHex
        .Pattern = "@[0-9A-Z]{8}\.[0-9A-Z]{8}"
     End With

Set mImgTag = rImgTag.Execute(sInput)

If mImgTag.Count <> 0 Then
    sImgTag = mImgTag.Item(0)
End If


Set mBadHex = rBadHex.Execute(sImgTag)

If mBadHex.Count <> 0 Then
    sBadHex = mBadHex.Item(0)
End If

GetBadHex = sBadHex
Set rImgTag = Nothing
Set rBadHex = Nothing

End Function

Outlook VBA宏以使用正文中的图像创建和转发电子邮件

2 个答案: