vba - ejemplos - Eliminar archivos adjuntos en línea

vba outlook object properties

Question

Estoy intentando buscar correos electrónicos seleccionados y eliminar los archivos adjuntos. Hice un poco de investigación y terminé yendo con la ruta de Word.Document.

Tenía un tidbit anterior de código que eliminaba todos los archivos adjuntos pero dejaba atrás un cuadro de líneas de puntos que decía que la imagen no estaba disponible.

Estoy tratando de unir los dos, ya que a continuación no se eliminan los archivos adjuntos, sino solo las formas en línea.

Código que borra imágenes en línea:

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

Para el código que estaba usando para eliminar todos los archivos adjuntos:

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

Answer 1

Hace muchos años, investigué archivos adjuntos en línea. Mi recuerdo es que los diferentes paquetes de correo electrónico los manejaban de maneras muy diferentes, por lo que es imposible dar instrucciones explícitas.

El problema básico es que está eliminando el archivo adjunto pero no el comando para mostrarlo en el cuerpo del correo electrónico.

Seleccione algunos de estos correos electrónicos y ejecute la macro a continuación. Crea un archivo en el escritorio llamado DemoExplorer, txt que contiene las propiedades seleccionadas de los correos electrónicos. Dentro del cuerpo Html encontrarás algo como esto:

<img width=2112 height=1186 style=''width:22.0in;height:12.3541in''
id="Picture_x0020_1" src="cid:[email protected]">

Debe eliminar este elemento IMG para eliminar la imagen del cuerpo Html.

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