Outlook VBA 用文本替换内联对象 [英] Outlook VBA Replace inline object with text
问题描述
我的收件箱中有一封电子邮件,其中包含一个内嵌对象(例如,图像).我想删除它,并在电子邮件的同一位置插入文本.
我尝试了两种方法:
使用
Dim objAttachment As Outlook.Attachment
处理对象.我尝试使用Position
方法,但问题是它总是返回0
,而不管对象的位置(以及它是内联的还是在附件栏").使用
Dim shp As Word.InlineShape
处理对象.我可以确定shp
的位置,使用Set shpRange = objDoc.Range(shp.Range.Characters.First.Start, shp.Range.Characters.Last.End)
(和Dim objDoc As Word.Document
;感谢 :"17.5 使用 WordEditorOutlook 对象模型本身没有提供直接的方法来确定光标在项目正文中的位置.但是,由于每个项目正文(便笺"和分发列表除外)的编辑器都是 Microsoft Word 的特殊版本,因此您不仅可以使用 Word 技术在插入点添加文本,还可以在任何位置添加格式化文本在项目中,甚至添加图片."可能的相关链接:
如何从 WordEditor 对象中获取选定的文本并更改其颜色?
我的代码:
Public Sub StripAttachments()'放入你想保存附件的文件夹位置Dim strFolder As StringstrFolder = "removed_attachments"Dim ilocation As Stringilocation = GetSpecialFolder(&H5) &" &strFolder ' CSIDL_MY_DOCUMENTS As Long = &H5"出错时继续下一步ilocation = ilocation &"' 实例化 Outlook 应用程序对象.将 objOL 调暗为 Outlook.Application设置 objOL = 应用程序' 获取选定对象的集合.Dim objSelection 作为 Outlook.Selection设置 objSelection = objOL.ActiveExplorer.Selection'将 objMsg 作为对象将 objMsg 调暗为 Outlook.MailItem' 检查每个选定项目的附件.如果附件存在,将它们保存到选定的' 文件夹并将它们从项目中删除.对于 objSelection 中的每个 objMsg' 此代码仅从邮件项目中删除附件.如果 (objMsg.Class = olMail) 那么Dim objInsp 作为 Outlook.Inspector设置 objInsp = objMsg.GetInspector将 objDoc 变暗为 Word.Document设置 objDoc = objInsp.WordEditor' 获取项目的附件集合.Dim objAttachments 作为 Outlook.attachments设置 objAttachments = objMsg.attachmentsDim lngCount As LonglngCount = objAttachments.Count如果 lngCount >0 那么' 我们需要使用倒计时循环从集合中删除项目.否则,' 循环计数器变得混乱,只有其他所有项目都被删除.Dim strFile 作为字符串strFile = ""昏暗的我For I = lngCount To 1 Step -1' 从项目中删除之前保存附件.' 获取文件名.Dim objAttachment 作为 Outlook.Attachment设置 objAttachment = objAttachments.item(I)Dim strHTML As StringstrHTML = "<li><a href=" &Chr(34) &文件:"&ilocation &objAttachment.FileName &铬(34)_&>"&objAttachment.FileName &</a><br>"&vbCrLfstrFile = strFile &字符串HTMLDim attPos As LongattPos = objAttachment.Position' 将附件另存为文件objAttachment.SaveAsFile (ilocation & objAttachments.item(I))' 删除附件对象附件.删除' 替换为文本和超链接'strFile = "从邮件中删除附件并备份到 [<a href='" &ilocation &"'>"&ilocation &</a>]:<br><ul>"&strFile &</ul><hr><br><br>"&vbCrLf &vbCrLf接下来我strFile = "从邮件中删除附件并备份到 [<a href='" &ilocation &"'>"&ilocation &</a>]:<br><ul>"&strFile &</ul><hr><br><br>"&vbCrLf &vbCrLfobjDoc.Characters(1).InsertBefore strFile ' 什么都不做!objMsg.HTMLBody = strFile + objMsg.HTMLBodyobjMsg. 保存别的msgbox ("在选定的电子邮件中没有找到附件")万一别的msgbox ("选择的不是 olMail 类型")万一下一个退出子:设置 objAttachments = 无设置 objMsg = 无设置 objSelection = 无设置 objOL = 无结束子
WordEditor
基本上是一个词 Document
如果我没记错的话,所以你应该可以做到类似于(在 Word 中测试,可能需要针对 Outlook 进行调整),假设使用像 doc
这样的对象变量来表示 Document
:
修订版&在 Outlook 2010 中测试
将 shp 变暗为 InlineShapeDim doc 作为对象`Word.DocumentDim shpRange 作为对象`Word.RangeConst wdInlineShapePicture as Long = 3Const wdInlineShapesEmbeddedOLEObject as Long = 1设置 doc = objMsg.GetInspector.WordEditor对于每个 shp 在 doc.InlineShapes 中选择 Case shp.Type案例 wdInlineShapePicture, wdInlineShapesEmbeddedOLEObject'## 用形状的文本位置分配一个范围对象设置 shpRange = doc.Range(shp.Range.Characters.First.Start, _shp.Range.Characters.Last.End)'## 用文本替换形状:shpRange.Text = "替换文本"其他情况'## 为其他形状类型等做其他事情.结束选择下一个
这是一个示例宏,用于处理传入的邮件项目,并用文本替换嵌入的图像.注意需要UnProtect
文档:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)Dim arr() 作为字符串Dim i 作为整数昏暗为邮件项目'## Word 对象,使用后期绑定(或启用对 MS Word 的引用)Dim shp As Object 'Word.InlineShapeDim doc As Object 'Word.DocumentDim shpRange 作为对象 'Word.Range'## 建立一些用于后期绑定的字常量Const wdInlineShapePicture As Long = 3Const wdInlineShapeEmbeddedOLEObject As Long = 1Const wdInlineShapeLinkedPicture As Long = 4arr = Split(EntryIDCollection, ",")对于 i = 0 到 UBound(arr)设置 m = Application.Session.GetItemFromID(arr(i))设置 doc = m.GetInspector.WordEditordoc.UnProtect对于每个 shp 在 doc.InlineShapes 中选择 Case shp.Type案例 wdInlineShapePicture, _wdInlineShapeEmbeddedOLEObject, _wdInlineShapeLinkedPicture'## 用形状的文本位置分配一个范围对象设置 shpRange = doc.Range(shp.Range.Characters.First.Start, _shp.Range.Characters.Last.End)'## 用文本替换形状:shpRange.Text = "替换文本"其他情况结束选择下一个下一个结束子
I have an email message in my Inbox which contains an inline object (e.g., an image). I want to remove it, and insert text at the same point in the email.
I tried with two methods:
Dealing with objects with
Dim objAttachment As Outlook.Attachment
. I tried using thePosition
method, but the problem is that it always returns0
, regardless of the position of the object (and whether it is inline or in the "attachments bar").Dealing with objects with
Dim shp As Word.InlineShape
. I could determine the location ofshp
, withSet shpRange = objDoc.Range(shp.Range.Characters.First.Start, shp.Range.Characters.Last.End)
(andDim objDoc As Word.Document
; thanks to an answer below). I tried modifyingobjDoc
in three ways.2.1.
shpRange.InsertAfter "Replacement Text 1"
.2.2.
shpRange.Text = "Replacement Text 2"
.2.3.
objDoc.Characters(1).InsertBefore "New Text"
.The problem is that none of them modifies the email.
So far, I have used method 1 with objMsg.HTMLBody = <mytext> + objMsg.HTMLBody
, then objMsg.Save
. But this adds text at the beginning.
PS: when one replies to an email with an inline object, it is sometimes replaced with text at the location of the object (I could not ascertain when this is done). Perhaps MS does not provide functionality for accomplishing the same.
EDIT (Extra details, originally not included to avoid tl;dr)
Notes:
The code I am currently using is based on a post by Nicola Delfino. It uses
objMsg.HTMLBody
, see below. On the up side, it finds most inline attachments/objects (some are missed), and all in the "attachments bar" (I do not know the official name for it). On the down side, it cannot discriminate inline from "bar-attached" items, and it cannot get the location of inline objects found. So I had it add text only at the beginning of the mail body.I see the problem with any email I tried. For instance, I have created an email, and inserted a picture with
Insert -> Picture
. After sending the email, I worked with the email in mySent Items
folder.I am attaching an image of a sample email that I used for testing.
It might be the case that
objMsg.HTMLBody
could never work, and that I should go withWordEditor
, after reading this official page for Outlook 2007: "17.5 Using WordEditor The Outlook object model itself provides no direct way to determine the position of the cursor in an item body. However, since the editor for every item body (except on "sticky notes" and distribution lists) is a special version of Microsoft Word, you can use Word techniques not only to add text at the insertion point, but also to add formatted text anywhere in the item, or even to add a picture."Possibly relevant links:
How do I get the selected text from a WordEditor Object and change it's color?
Deletion of InlineShape does not work for RTF mails
My code:
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
The WordEditor
basically is a word Document
if I remember correctly, so you should be able to do something similar to (tested in Word, may need tweak for Outlook), assuming an object variable like doc
to represent the Document
:
Revised & tested in Outlook 2010
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
Here is an example macro to process incoming mailitems, and replace the embedded images with text. Note the need to UnProtect
the document:
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
这篇关于Outlook VBA 用文本替换内联对象的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!