Forward incoming email with 4 embedded images in the body without original sender

[fuz]

Hi,
I am trying to forward an email with 4 embedded images without original sender. The following script gets rid of the original sender, but the images are displaying as red X in the forwarded email. Direct forward set up as a rule displays the embedded images nicely, but with the original sender email. Is there a way to forward email with embedded images display and hide the original sender email at the same time?

Thank you for any help!

Sub SendTransfer(Item As Outlook.MailItem)

Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)

objMsg.HTMLBody = Item.HTMLBody
objMsg.Display
objMsg.Subject = "Transfers" & Item.Subject
objMsg.Recipients.Add "xxx@xxxx"

objMsg.Send

End Sub

 

[Diane Poremsky]

Try using the word object model to copy and paste... not sure it will be any better though.

The macro at the bottom is for testing - select a message then run the macro - it beats sending test messages or running rules.

Sub SendTransfer(Item As Outlook.MailItem)

Dim objMsg As MailItem
   ' Add reference to Word library
    ' in VBA Editor, Tools, References
    Dim objWord As Word.Application
    Dim objInsp As Inspector
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection
  
    On Error Resume Next
    
If Not Item Is Nothing Then
   If Item.Class = olMail Then
       Set objInsp = Item.GetInspector
       If objInsp.EditorType = olEditorWord Then
           Set objDoc = objInsp.WordEditor
           Set objWord = objDoc.Application
           Set objSel = objWord.Selection
   With objSel
      'use wholestory to copy the entire message body
        .WholeStory
        .Copy
  End With

       End If
   End If
End If
    
Set objMsg = Application.CreateItem(olMailItem)

 Set objInsp = objMsg.GetInspector
 Set objDoc = objInsp.WordEditor
 Set objSel = objDoc.Windows(1).Selection

With objMsg
    .Subject = "Transfers " & Item.Subject
    .Recipients.Add "xxx@xxxx"
     objSel.PasteAndFormat (wdFormatOriginalFormatting)
    .Display
    '.Send
End With

End Sub

Sub TestForwardMacro()
Dim objApp As Outlook.Application
Dim objItem As Object ' MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)

'macro name you want to run goes here
SendTransfer objItem

End Sub

 

[fuz]

Hi Diane,

Thank you for your response. The 'Dim objWord As Word.Application' was highlighted, and the following error message pop up. How to fix it?

Thank you,
fuz

 

[fuz]

I added the 16.0 word object library in the reference.

 

[Diane Poremsky]

Oh sorry, I forgot to mention that you needed to reference the library. Did it do what you needed it to do?

Including images can be tough because they are attachments embedded in the HTML and just copying the body may not include them. If it doesn't work, removing the header block would be the next thing to try.

 

[fuz]

Oh sorry, I forgot to mention that you needed to reference the library. Did it do what you needed it to do?

Including images can be tough because they are attachments embedded in the HTML and just copying the body may not include them. If it doesn't work, removing the header block would be the next thing to try.

There was a box popup saying 'an unknown error' has occurred. The email didn't get forwarded.

 

[Diane Poremsky]

It doesn't show you which line was the problem?

It works here when I select a message and run it (using the stub macro at the end). I didn't try it with a rule.

 

[fuz]

Hi Diane,
The VBA window did not open up, so I didn't see which line was highlighted. The popup box has one line: the name of the script and message -an unknown error has occurred. BTW, am I supposed to put the lines of macro in the script? I didn't
Thank you,
Fuz

 

[Diane Poremsky]

This part is a separate macro, used to run the script on the selected message, so you don't need to send messages to test the rule.

Sub TestForwardMacro()
Dim objApp As Outlook.Application
Dim objItem As Object ' MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)

'macro name you want to run goes here
SendTransfer objItem

End Sub

Select a message and run this macro - do you get the same error? If yes and it doesn't show you were it stopped, you can step through the macro to see where it is dying.

 

[Diane Poremsky]

I supposed to put the lines of macro in the script?

in re-reading this - if you meant, how do you merge your script and mine - you don't. Mine replaces yours.

 

[fuz]

Hi Diane,

Today the script does an unexpected thing. The incoming email arrives at 2 pm. At that time I happened to have some random sentences copied in my clip board. This script pasted the content what I had copied into the outgoing email and sent. (I ended up sending a strange email.) It seems the script didn't specify to copy the content in the incoming email that is specified by sender and subject within the rule prior to running the script. It sends whatever I copied at that moment instead. Please let me know your thoughts.

This is the script I am using

Sub SendTransfer(Item As Outlook.MailItem)
 
Dim objMsg As MailItem
   ' Add reference to Word library
    ' in VBA Editor, Tools, References
    Dim objWord As Word.Application
    Dim objInsp As Inspector
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection
 
    On Error Resume Next
   
If Not Item Is Nothing Then
   If Item.Class = olMail Then
       Set objInsp = Item.GetInspector
       If objInsp.EditorType = olEditorWord Then
           Set objDoc = objInsp.WordEditor
           Set objWord = objDoc.Application
           Set objSel = objWord.Selection
   With objSel
      'use wholestory to copy the entire message body
        .WholeStory
        .Copy
  End With


       End If
   End If
End If
   
Set objMsg = Application.CreateItem(olMailItem)


 Set objInsp = objMsg.GetInspector
 Set objDoc = objInsp.WordEditor
 Set objSel = objDoc.Windows(1).Selection


With objMsg
    .Subject = "Transfers" & Item.Subject
    .Recipients.Add "xxx@xxx"
     objSel.PasteAndFormat (wdFormatOriginalFormatting)
    .Display
    .Send
End With




End Sub

 

[Diane Poremsky]

Best guess: it failed on the copy and pasted the last thing copied to the clipboard.

If you copied at the same time as the macro, it would pick up what was copied last. If you had a message open and was actively working in it, it could pick that up.

I usually run the macro manually to copy messages to tasks or appointments.

 

[fuz]

Best guess: it failed on the copy and pasted the last thing copied to the clipboard.

If you copied at the same time as the macro, it would pick up what was copied last. If you had a message open and was actively working in it, it could pick that up.

I usually run the macro manually to copy messages to tasks or appointments.

So i should try not doing anything around the time (2 pm) to see if the rule that running the script would work?

 

[Diane Poremsky]

if you expect the messages that match the rule come in at 2PM, yeah, pause and see what happens. Comment out .send so you can see if it screws up before it sends. If it uses the last copied item, the problem is the copy code.

 

[fuz]

Yes the problem is the copy code. It didn't copy anything from the content of the incoming email body.

 

[Diane Poremsky]

ok... it works manually, but not automated. Back to the drawing board...

 

[Diane Poremsky]

BTW - a quick fix might be to add item.display before the inspector - it will flash on the screen and be annoying...


If Not Item Is Nothing Then
If Item.Class = olMail Then
item.display

<code to copy>

item.close <== can be early or after the message is sent
End If
End If
End If


- to close it later - add it after the message is sent

With objMsg
.Subject = "Transfers" & Item.Subject
.Recipients.Add "xxx@xxx"
objSel.PasteAndFormat (wdFormatOriginalFormatting)
.Display
.Send
End With

item.close

 

[fuz]

Today I tested the following script and got a message. The VBA editor didn't open at all, so no code highlighted. I am going to test your suggestion tomorrow.

Sub SendTransfer(Item As Outlook.MailItem)
 
Dim objMail As Outlook.MailItem
    Dim objMailDocument As Word.Document
    Dim objDocSelection As Word.Selection
    Dim objNewMail As Outlook.MailItem
    Dim objNewMailDocument As Word.Document
    Dim objInlineShape As Word.InlineShape
    Dim objShape As Word.Shape
 
    'Get the source email
    Select Case Outlook.Application.ActiveWindow.Class
           Case olInspector
                Set objMail = ActiveInspector.CurrentItem
           Case olExplorer
                Set objMail = ActiveExplorer.Selection.Item(1)
    End Select
 
    'Copy the entire email to a new email
    Set objMailDocument = objMail.GetInspector.WordEditor
    Set objDocSelection = objMailDocument.Application.Selection
    objDocSelection.WholeStory
    objDocSelection.Copy
 
    Set objNewMail = Outlook.Application.CreateItem(olMailItem)
    objNewMail.Display
    Set objNewMailDocument = objNewMail.GetInspector.WordEditor
    objNewMailDocument.Application.Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
      

    For Each objInlineShape In objNewMailDocument.InlineShapes
        objInlineShape.ConvertToShape
    Next
 
    'Clear the text in the new email
    With objNewMailDocument.Content.Find
         .ClearFormatting
         .Replacement.ClearFormatting
         .Text = "[^2-^255]{1,}"
         .Replacement.Text = ""
         .MatchWildcards = True
         .Execute Replace:=wdReplaceAll
    End With
 
    Do While objNewMailDocument.Shapes.Count > 0
       For Each objShape In objNewMailDocument.Shapes
           objShape.ConvertToInlineShape
       Next
    Loop

With objNewMail
    .Subject = "Transfers" & Item.Subject
    .Recipients.Add "xx@xxx"
    .Send
End With


End Sub

 

[fuz]

Hi Diane,

Your suggestion got the following error. Do you know how to fix it?

Thank you,
Fuz

 

[Diane Poremsky]

oops, sory - try
item.Close olDiscard