删除内联附件 [英] Deleting inline attachments
问题描述
我正在尝试搜索选定的电子邮件并删除附件.我做了一些研究,最后选择了Word.Document路由.
I'm trying to search selected emails and delete the attachments. I did a bit of research and ended up going with the Word.Document route.
我以前有一段代码花絮,删除了所有附件,但是留下了一个虚线框,说该图像不可用.
I had a previous tidbit of code that deleted all the attachments but was leaving behind a dotted line box that said the image wasn't available.
我正在尝试将两者网格化,因为下面的这一步不会删除附件,而只会删除内嵌形状.
I'm trying to mesh the two as this one below does not delete attachments but only the inline shapes.
删除嵌入式图像的代码:
Code that deletes inline images:
Sub DeleteAllAttachmentsFromSelectedMessages()
Dim selectedItems As Selection
Dim messageObject As Object
Dim documentsObject As Object
Dim shp As InlineShape
Dim doc As Object
Dim shpRange As Object
Const wdInlineShapePicture As Long = 3
Const wdInlineShapesEmbeddedOLEObject As Long = 1
' Set reference to the Selection.
Set selectedItems = ActiveExplorer.Selection
For Each messageObject In selectedItems
Set doc = messageObject.GetInspector.WordEditor
' doc.UnProtect
For Each shp In doc.InlineShapes
Select Case shp.Type
Case wdInlineShapePicture, wdInlineShapesEmbeddedOLEObject
Set shpRange = doc.Range(shp.Range.Characters.First.Start, shp.Range.Characters.Last.End)
shpeRange.Text = "Attachment Removed" ' Replace shape with text
Case Else
' Other shapes not supported yet
End Select
' doc.Protect
messageObject.Save
Next
Next
MsgBox "Attachments were removed.", vbOKOnly, "Message"
Set selectedItems = Nothing
Set messageObject = Nothing
Set documentsObject = Nothing
Set shp = Nothing
Set doc = Nothing
Set shpRange = Nothing
End Sub
对于我用来删除所有附件的代码:
For the code I was using to delete all attachments:
Sub DeleteAllAttachmentsFromSelectedMessages()
Dim attachmentsObject As Attachments
Dim selectedItems As Selection
Dim messageObject As Object
Dim attachmentCount As Long
Set selectedItems = ActiveExplorer.Selection
For Each messageObject In selectedItems
Set attachmentsObject = messageObject.Attachments
attachmentCount = attachmentsObject.Count
While attachmentCount > 0
attachmentsObject(1).Delete
attachmentCount = attachmentsObject.Count
Wend
messageObject.Save
Next
MsgBox "Attachments were removed.", vbOKOnly, "Message"
Set attachmentsObject = Nothing
Set selectedItems = Nothing
Set messageObject = Nothing
End Sub
推荐答案
很多年前,我研究了内联附件.我的回忆是,不同的电子邮件程序包以不同的方式处理它们,因此不可能给出明确的指示.
Many years ago, I investigated inline attachments. My recollection is that different email packages handled them in very different ways so it is impossible to give explicit instructions.
基本问题是您要删除附件,而不是删除要在电子邮件正文中显示附件的命令.
The basic problem is that you are deleting the attachment but not the command to display it within the body of the email.
选择其中一些电子邮件,然后运行下面的宏.它在桌面上创建一个名为DemoExplorer,txt的文件,其中包含电子邮件的选定属性.在HTML正文中,您会发现以下内容:
Select some of these emails and run the macro below. It creates a file on the desk top named DemoExplorer,txt containing selected properties of the emails. Within the Html body you will find something like this:
<img width=2112 height=1186 style='width:22.0in;height:12.3541in'
id="Picture_x0020_1" src="cid:image001.jpg@01D22C6F.05449B60">
您必须删除此IMG元素才能从HTML正文中删除图像.
You must delete this IMG element to remove the image from the Html body.
Public Sub DemoExplorer()
' Outputs selected properties of selected emails to a file.
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
' Needs reference to Microsoft Scripting Runtime if "TextStream"
' and "FileSystemObject" are to be recognised
‘ Coded by Tony Dallimore
Dim AttachCount As Long
Dim AttachType As Long
Dim FileOut As TextStream
Dim Fso As FileSystemObject
Dim Exp As Outlook.Explorer
Dim InxA As Long
Dim ItemCrnt As MailItem
Dim NumSelected As Long
Dim Path As String
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FileOut = Fso.CreateTextFile(Path & "\DemoExplorer.txt", True)
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemCrnt In Exp.Selection
With ItemCrnt
FileOut.WriteLine "--------------------------"
FileOut.WriteLine "From: " & .SenderName
FileOut.WriteLine "Subject: " & .Subject
FileOut.WriteLine "Received: " & Format(.ReceivedTime, "dMMMyy h:mm:ss")
FileOut.WriteLine "Text: " & Replace(Replace(Replace(.Body, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
FileOut.WriteLine "Html: " & Replace(Replace(Replace(.HtmlBody, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
AttachCount = .Attachments.Count
FileOut.WriteLine "Number of attachments: " & AttachCount
For InxA = 1 To AttachCount
AttachType = .Attachments(InxA).Type
FileOut.WriteLine "Attachment " & InxA
FileOut.Write " Attachment type: "
Select Case AttachType
Case olByValue
FileOut.WriteLine "By value"
Case olEmbeddeditem
FileOut.WriteLine "Embedded item"
Case olByReference
FileOut.WriteLine "By reference"
Case olOLE
FileOut.WriteLine "OLE"
Case Else
FileOut.WriteLine "Unknown " & AttachType
End Select
' I recall PathNasme giving an error for some types
On Error Resume Next
FileOut.WriteLine " Path: " & .Attachments(InxA).PathName
On Error GoTo 0
FileOut.WriteLine " File name: " & .Attachments(InxA).FileName
FileOut.WriteLine " Display name: " & .Attachments(InxA).DisplayName
' I do not recall every seeing a parent but it is listed as a property
' but for some attachment types it gives an error
On Error Resume Next
FileOut.WriteLine " Parent: " & .Attachments(InxA).Parent
On Error GoTo 0
FileOut.WriteLine " Position: " & .Attachments(InxA).Position
Next
End With
Next
End If
FileOut.Close
End Sub
这篇关于删除内联附件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!