Request help with a macro for forwarding email

[dhsanjay]

Operating system::    Windows
Outlook version:     Outlook 2019
Email type or host:    exchange server

---

Dear Team,
Greetings. I am a novice in VBA.
Request your kind help with a macro to do the following activity on standardized emails.
Step 1) Forward the open mail with attachments
Step 2) Copy paste the body of the original email into the body of the new mail, at the top.
Step 3) Delete part of the body of the old mail. i.e. keep only the top 3 lines of the body. else since these 3 lines are standard, we can also insert later aftre deleting.
Step 4) add to email addresses.
Step 5) add cc email addresses.
Step 6) Display/ Show the new email on screen, to review.

Would be very grateful.

Regards
DHS

 

[Diane Poremsky]

Step 1) Forward the open mail with attachments
Easy.

Step 2) Copy paste the body of the original email into the body of the new mail, at the top.
You want to replace the body with the forward header with just the body, correct? That is easy.

Step 3) Delete part of the body of the old mail. i.e. keep only the top 3 lines of the body. else since these 3 lines are standard, we can also insert later after deleting.
Exactly 3 lines or a specific number of characters? Specific # of characters or sentences / paragraphs is easy. Actual lines you see on the screen is hard, possibly impossible.

Step 4) add to email addresses.
Easy
Step 5) add cc email addresses.
Easy
Step 6) Display/ Show the new email on screen, to review.
Easy

This will do all but possibly step 3 - it uses first 1000 characters. Counting sentences or paragraphs would need some code from word added.

Sub ForwardEmail()
    Dim Item As Outlook.MailItem
    Dim myForward As Outlook.MailItem
    
' The first line is if you read the message in the reading pane, second is for opened message.
' The first line *should* work even on opened messages as long as it is still selected.
Set Item = Application.ActiveExplorer.Selection.Item(1)
'Set Item = Application.ActiveInspector.CurrentItem

Set myForward = Item.Forward
myForward.Body = Left(Item.Body, 1000)
myForward.Recipients.Add "alias@domain.com"
myForward.CC = "alias1@domain.com"
myForward.BCC = "alias2@domain.com"

myForward.Display

End Sub

 

[Diane Poremsky]

BTW - if you want html formatting, it's
myForward.HTMLBody = Left(Item.HTMLBody, 1000)

But... the underlying html code counts towards the character count.

This screenshot will give you an idea of how much could be lost to HTML code - the plain text version has more lines not shown in the screenshot.

 

[dhsanjay]

Thank you Diane Madam.
I also submit my apologies for not explaining properly.
Actually lets say oldmail and fwdmail for clarity sake.
What I want is the oldmail to be forwarded and the following to be added.
the fwdmail shall have a copy of th ebody of the oldmail copied into the body at th etop with the oldmail appended as in the normal format of oldmail forwarded.
i.e
1) the body of the fwdmail begins with copy of the entire body of oldmail without signatures.
2) below will be the normal oldmail with the (a) headers as is (b) the earlier body and (c) signatures and (d) any trailing mails which had been appended earlier.
3) all above in HTML format i.e. rich text without losing any formatting.
4) now in the body of the oldmail we can have two choices as below :-
4a) either leave the top 4 or 5 lines and rest of the body alone deleted leaving the signatures and trailing email as is.
4b) or the entire body of the oldmail deleted and since the statment is standard like below which can be added, but not deleting the signature and the trailing mails.
"Dear Sir,

Please find the details of PO. Request for your approval.

Regards"
5) I will try to show a schematic of what i want on the screen in the fwdmail after clicking button for forwarding.
the ribbon
to name1@domain.com
cc name2@domain.com, name3@domain.com, name4@domain.com '''' "[[ all are internal to the organisaton, suggest if only names can be added in the macro which will turn into email ds later in the email]] "
bcc
Subject : same as earlier except that the first 3 character "FW :" to be deleted
Body of fwdmail
the body copyied from oldmail
with my signature
the oldmail with the normal way of headers
the body of the oldmail with only the 4a or 4b whichever is easier
signature of oldmail
trailing emails if any

6) please also advise how to add a button for this macro to run - i know the earlier design of 2008 but after that the ribbon is little confusing to me.

Thanks once again for your kind help will be remembered for long.
Appreciate your efforts as well.

Thanks and Regards
DHS

 

[Diane Poremsky]

Subject:
myForward.Subject = Item.subject


Keeping the forward part is mostly easy - removing signatures from an incoming message is hard. One option could be to select what you want to keep then run the macro - will add that code in a new message.

1) the body of the fwdmail begins with copy of the entire body of oldmail without signatures.
2) below will be the normal oldmail with the (a) headers as is (b) the earlier body and (c) signatures and (d) any trailing mails which had been appended earlier.

The vbcrlf adds a blank line - you can use more to add more lines "& vbcrlf & vbcrlf &" would add two blanks.

myForward.htmlBody = Left(Item.htmlBody, 1000) & vbcrlf & forward.htmlbody ' or item.htmlbody if you don't want the forward header

 

[Diane Poremsky]

For this macro - you select the text you want to copy, then run the macro. Result is in the second screenshot.







This code is a version of these macros on this page - the instructions to set the references to Word are at the end of the article.
Create Task or Appointment and Insert Selected Text | Slipstick Systems

Sub ConvertSelectionEmail()

    Dim objNewMail As Outlook.MailItem
    Dim objMail As Outlook.MailItem
  
    ' Add reference to Word library
    ' in VBA Editor, Tools, References
    Dim objInsp As Inspector
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection

    Set objMail = Application.ActiveExplorer.Selection.Item(1)
      
    On Error Resume Next
 
  If Not objMail Is Nothing Then
        If objMail.Class = olMail Then
            Set objInsp = objMail.GetInspector
            If objInsp.EditorType = olEditorWord Then
                Set objDoc = objInsp.WordEditor
                Set objWord = objDoc.Application
                Set objSel = objWord.Selection
        With objSel
             .Copy
       End With
 
            End If
        End If
    End If
    

Set objNewMail = objMail.Forward
    
    Set objInsp = objNewMail.GetInspector
    Set objDoc = objInsp.WordEditor
    Set objSel = objDoc.Windows(1).Selection

With objNewMail
    .CC = "alias1@domain.com"
    .BCC = "alias2@domain.com"
    .Subject = objMail.Subject
    objSel.PasteAndFormat (wdFormatOriginalFormatting)
    
' uses word vba to add blank lines
    objSel.Range.InsertParagraphBefore
    objSel.Range.InsertParagraphBefore
    
    .Display
End With
    
    Set objNewMail = Nothing
    Set objMail = Nothing
End Sub