Outlook VBA将内联对象替换为文本
我的收件箱中有一封包含内联对象（例如图像）的电子邮件。我想删除它，并在电子邮件中的同一点插入文本 我尝试了两种方法：Outlook VBA将内联对象替换为文本,vba,outlook,email-attachments,Vba,Outlook,Email Attachments,我的收件箱中有一封包含内联对象（例如图像）的电子邮件。我想删除它，并在电子邮件中的同一点插入文本 我尝试了两种方法： 处理带有暗淡对象附件的对象，如Outlook.Attachment。我尝试使用Position方法，但问题是它总是返回0，而不管对象的位置（以及它是内联的还是在“附件栏”中） 将尺寸为shp的对象处理为Word.InlineShape。我可以通过设置shpRange=objDoc.Range（shp.Range.Characters.First.Start，shp.Range.C
暗淡对象附件的对象，如Outlook.AttachmentPosition0尺寸为shp的对象处理为Word.InlineShape设置shpRange=objDoc.Range（shp.Range.Characters.First.Start，shp.Range.Characters.Last.End）将objDoc变暗为Word.DocumentobjDocobjDoc.Characters（1）.在“新文本”之前插入objMsg.HTMLBody=+objMsg.HTMLBodyobjMsg.Save编辑（额外细节，最初不包括以避免tl；dr） 注:
objMsg.HTMLBodyInsert->picture已发送邮件objMsg.HTMLBodyWordEditor Public Sub StripAttachments()
'Put in the folder location you want to save attachments to
Dim strFolder As String
strFolder = "removed_attachments"
Dim ilocation As String
ilocation = GetSpecialFolder(&H5) & "\" & strFolder ' CSIDL_MY_DOCUMENTS As Long = &H5"
On Error Resume Next
ilocation = ilocation & "\"
' Instantiate an Outlook Application object.
Dim objOL As Outlook.Application
Set objOL = Application
' Get the collection of selected objects.
Dim objSelection As Outlook.Selection
Set objSelection = objOL.ActiveExplorer.Selection
'Dim objMsg As Object
Dim objMsg As Outlook.MailItem
' Check each selected item for attachments. If attachments exist, save them to the selected
' folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
If (objMsg.Class = olMail) Then
Dim objInsp As Outlook.Inspector
Set objInsp = objMsg.GetInspector
Dim objDoc As Word.Document
Set objDoc = objInsp.WordEditor
' Get the Attachments collection of the item.
Dim objAttachments As Outlook.attachments
Set objAttachments = objMsg.attachments
Dim lngCount As Long
lngCount = objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for removing items from a collection. Otherwise,
' the loop counter gets confused and only every other item is removed.
Dim strFile As String
strFile = ""
Dim I As Long
For I = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
Dim objAttachment As Outlook.Attachment
Set objAttachment = objAttachments.item(I)
Dim strHTML As String
strHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachment.FileName & Chr(34) _
& ">" & objAttachment.FileName & "</a><br>" & vbCrLf
strFile = strFile & strHTML
Dim attPos As Long
attPos = objAttachment.Position
' Save the attachment as a file
objAttachment.SaveAsFile (ilocation & objAttachments.item(I))
' Remove the attachment
objAttachment.Delete
' Replace with text and hyperlink
'strFile = "Attachments removed from the message and backed up to [<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
Next I
strFile = "Attachments removed from the message and backed up to [<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
objDoc.Characters(1).InsertBefore strFile ' Does nothing!
objMsg.HTMLBody = strFile + objMsg.HTMLBody
objMsg.Save
Else
msgbox ("No attachments were found in the selected email")
End If
Else
msgbox ("Selection is not of type olMail")
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public子带附件（）
'放入要保存附件的文件夹位置
作为字符串的Dim strFolder
strFolder=“已删除附件”
作为字符串的Dim-ilocation
ilocation=GetSpecialFolder（&H5）和“\”&strFolder'CSIDL\u MY\u文档长度=&H5”
出错时继续下一步
ilocation=ilocation&“\”
'实例化Outlook应用程序对象。
将objOL设置为Outlook.Application
Set objOL=应用程序
'获取选定对象的集合。
Dim objSelection作为Outlook.Selection
设置objSelection=objOL.ActiveExplorer.Selection
'Dim objMsg As Object
将objMsg设置为Outlook.MailItem
'检查每个选定项目的附件。如果存在附件，请将其保存到选定项目
'文件夹并将其从项目中删除。
对于objSelection中的每个objMsg
'此代码仅从邮件项目中删除附件。
如果（objMsg.Class=olMail），则
将对象设置为Outlook.Inspector
设置objInsp=objMsg.GetInspector
Dim objDoc作为Word.Document
设置objDoc=objInsp.WordEditor
'获取项目的附件集合。
将对象附件设置为Outlook.attachments
设置objAttachments=objMsg.attachments
暗计数等于长
lngCount=objAttachments.Count
如果lngCount>0，则
'我们需要使用倒计时循环从集合中删除项目。否则，
'循环计数器变得混乱，仅删除其他所有项。
作为字符串的Dim strFile
strFile=“”
我想我会坚持多久
对于I=lngCount到1步骤-1
'在从项目中删除之前保存附件。
'获取文件名。
Dim objAttachment作为Outlook.Attachment
Set objAttachment=objAttachments.item（I）
作为字符串的Dim strHTML
strHTML=“
”&vbCrLf
strFile=strFile&strHTML
将attPos变暗为长
attPos=对象连接位置
'将附件另存为文件
objAttachment.SaveAsFile（ilocation&objAttachments.item（I））
'删除附件
objAttachment.Delete
'替换为文本和超链接
'strFile=“从邮件中删除附件并备份到[]：
”&strFile&“
”&vbCrLf&vbCrLf
接下来我
strFile=“已从中删除附件
Dim shp as InlineShape
Dim doc as Object `Word.Document
Dim shpRange as Object `Word.Range
Const wdInlineShapePicture as Long = 3
Const wdInlineShapesEmbeddedOLEObject as Long = 1
Set doc = objMsg.GetInspector.WordEditor
For Each shp In doc.InlineShapes
Select Case shp.Type
Case wdInlineShapePicture, wdInlineShapesEmbeddedOLEObject
'## Assign a range object with the text position of the shape
Set shpRange = doc.Range(shp.Range.Characters.First.Start, _
shp.Range.Characters.Last.End)
'## Replace the shape with text:
shpRange.Text = "Replacement Text"
Case Else
'## Do something else for other shape types, etc.
End Select
Next
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim m As MailItem
'## Word objects, using late-binding (or enable reference to MS Word)
Dim shp As Object 'Word.InlineShape
Dim doc As Object 'Word.Document
Dim shpRange As Object 'Word.Range
'## Establish some word constants for use with late-binding
Const wdInlineShapePicture As Long = 3
Const wdInlineShapeEmbeddedOLEObject As Long = 1
Const wdInlineShapeLinkedPicture As Long = 4
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set m = Application.Session.GetItemFromID(arr(i))
Set doc = m.GetInspector.WordEditor
doc.UnProtect
For Each shp In doc.InlineShapes
Select Case shp.Type
Case wdInlineShapePicture, _
wdInlineShapeEmbeddedOLEObject, _
wdInlineShapeLinkedPicture
'## Assign a range object with the text position of the shape
Set shpRange = doc.Range(shp.Range.Characters.First.Start, _
shp.Range.Characters.Last.End)
'## Replace the shape with text:
shpRange.Text = "Replacement Text"
Case Else
End Select
Next
Next
End Sub