2016-10-21 6 views
0

Ich versuche, ausgewählte E-Mails zu durchsuchen und Anhänge zu löschen. Ich habe ein wenig recherchiert und bin mit der Word.Document-Route fertig geworden.Inline-Anhänge löschen

Ich hatte einen früheren Leckerbissen von Code, der alle Anhänge löschte, aber hinter einer gestrichelten Linie Box ließ, die besagt, dass das Bild nicht verfügbar war.

Ich versuche, die beiden ineinander zu greifen, da diese unten Anhänge nicht löscht, sondern nur die Inline-Formen.

Code, der Inline-Bilder löscht:

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 

Für den Code, den ich alle Anhänge löschen wurde mit:

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 
+0

Können Sie ein Bild der Inline hinzufügen, über die Sie sprechen – 0m3r

Antwort

0

Vor vielen Jahren untersuchte ich Inline-Anhänge. Meine Erinnerung ist, dass verschiedene E-Mail-Pakete sie auf sehr unterschiedliche Weise behandelt haben, so dass es unmöglich ist, explizite Anweisungen zu geben.

Das grundlegende Problem ist, dass Sie den Anhang löschen, aber nicht den Befehl, um es im Körper der E-Mail anzuzeigen.

Wählen Sie einige dieser E-Mails und führen Sie das Makro unten aus. Es erstellt eine Datei auf dem Desktop namens DemoExplorer, txt enthält ausgewählte Eigenschaften der E-Mails. Im HTML-Körper wird es Ihnen so etwas wie dieses finden:

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

Sie müssen diese IMG-Element löschen Sie das Bild aus dem HTML-Körper zu entfernen.

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