复制和转发正文中包含图像的电子邮件
Copy and Forward Email With Images in Body
我正在尝试复制电子邮件正文并将其放入模板中，然后用户才能转发它。
原始电子邮件正文中的图像变成了内部带有红色 X 的空白框。
错误信息：
The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location.
我需要将原始图像复制到一个临时文件夹中，然后将它们重新插入到我的电子邮件中。
我的宏可以将图像复制到临时文件夹中。如何将这些图像放入最终电子邮件中？
更新：
我想出了如何将我的临时文件中的图像作为隐藏附件添加到我的电子邮件中。 （我在下面更新了我的代码）。我认为问题在于 HTML 图片标签仍在引用我旧电子邮件中图片的位置（例如：src="cid:image001.jpg@01D09693.82092260"）。
删除“@01D09693.82092260”是否会使标签从当前附件中获取图像？我该怎么做？
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
附件的 Add 方法 class 允许将文件附加到邮件。
您还需要使用 Attachment.PropertyAccessor 在附件上设置 PR_ATTACH_CONTENT_ID 属性 (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F)。请注意，附件 class 的 PropertyAccessor 属性 是在 Outlook 2007 中添加的。
您可能会发现 How do I embed image in Outlook Message in VBA? link 有帮助。
有关完整的示例代码，请参阅 vba email embed image not showing。
我自己解决了！
我求助于使用 RegEx 删除有问题的十六进制路径，以便将图像 link 转到当前附加的图像。让我的正则表达式正常工作花了很长时间，但这是最终代码！
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
我正在尝试复制电子邮件正文并将其放入模板中，然后用户才能转发它。
原始电子邮件正文中的图像变成了内部带有红色 X 的空白框。
错误信息：
The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location.
我需要将原始图像复制到一个临时文件夹中，然后将它们重新插入到我的电子邮件中。
我的宏可以将图像复制到临时文件夹中。如何将这些图像放入最终电子邮件中？
更新：
我想出了如何将我的临时文件中的图像作为隐藏附件添加到我的电子邮件中。 （我在下面更新了我的代码）。我认为问题在于 HTML 图片标签仍在引用我旧电子邮件中图片的位置（例如：src="cid:image001.jpg@01D09693.82092260"）。
删除“@01D09693.82092260”是否会使标签从当前附件中获取图像？我该怎么做？
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
附件的 Add 方法 class 允许将文件附加到邮件。
您还需要使用 Attachment.PropertyAccessor 在附件上设置 PR_ATTACH_CONTENT_ID 属性 (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F)。请注意，附件 class 的 PropertyAccessor 属性 是在 Outlook 2007 中添加的。
您可能会发现 How do I embed image in Outlook Message in VBA? link 有帮助。
有关完整的示例代码，请参阅 vba email embed image not showing。
我自己解决了！
我求助于使用 RegEx 删除有问题的十六进制路径，以便将图像 link 转到当前附加的图像。让我的正则表达式正常工作花了很长时间，但这是最终代码！
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