Macro to copy email body to new email

[Abdul]

Can some one please help me, I didn't wrote this macro but searched over Google and trying to make it work as I am needed, it doesn't even copy the replied email

I want to Run a macro on current opened email that it will do reply and then copy full email body and open and paste it in new mail where To , CC and Subject would be same as of reply email.

Will really appreciate if somebody can help me sorting out this macro

Sub Old_reply()
Dim objApp
Dim objInsp
Dim colCB
Dim objCBB
Dim Mail As Outlook.MailItem
On Error Resume Next
Set objApp = GetObject("", "Outlook.Application")
If objApp Is Nothing Then
Set objApp = Application.CreateObject("Outlook.Application")
End If
Set objInsp = objApp.ActiveInspector.CurrentItem
If TypeName(objInsp) = "Nothing" Then
MsgBox "No inspector window found"
Exit Sub
Else
Set colCB = objInsp.CommandBars
Set objCBB = colCB.FindControl(, 354) ' Reply
objCBB.Execute

Set objInsp = Nothing
Set colCB = Nothing
Set objInsp = objApp.ActiveInspector.CurrentItem
Set colCB = objInsp.CommandBars
Set objCBB = colCB.FindControl(, 3634) ' clear clipboard
objCBB.Execute
Set objCBB = colCB.FindControl(, 756) ' select all
objCBB.Execute
Set objCBB = colCB.FindControl(, 19) ' copy
objCBB.Execute

Set Mail = Outlook.CreateItem(olMailItem)
Mail.To = objInsp.To

Mail.CC = objInsp.CC

Mail.Subject = objInsp.Subject

objInsp.Body = Mail.Body
Mail.Display

Set objCBB = colCB.FindControl(, 22) ' paste
objCBB.Execute
Set Mail = Nothing
End If
End Sub

 

[Abdul]

Anybody there who can help me ?

 

[Diane Poremsky]

Sorry, I missed your post. So you want to reply to a message and create a new one, to the same people?


Sent from my Surface 2 using Tapatalk

 

[Abdul]

Yes it will be like this

- open current active window as in reply.
- copy the body of the email which it open in reply
- open new mail and paste the copied body text into it and it keeps the to , cc and subject same as reply

Thank you

 

[Diane Poremsky]

This code will copy the message to a new message. You don't need the toolbar commands. if you also wanted a reply, add this before the set mail =.
Set myReply = objInsp.Reply
myReply.Display

Sub Old_reply()
Dim objApp
Dim objInsp
Dim Mail As Outlook.MailItem
On Error Resume Next
Set objApp = GetObject("", "Outlook.Application")
If objApp Is Nothing Then
Set objApp = Application.CreateObject("Outlook.Application")
End If
Set objInsp = objApp.ActiveInspector.CurrentItem
If TypeName(objInsp) = "Nothing" Then
MsgBox "No inspector window found"
Exit Sub
Else
Set Mail = Outlook.CreateItem(olMailItem)
With Mail
.To = objInsp.To
.CC = objInsp.CC
.Subject = objInsp.Subject
.Body = objInsp.Body
.Display
End With

Set Mail = Nothing
End If
End Sub

 

[Abdul]

Dear Diane,

I really appreciated your help, I did some change in there so it will pick up to and put it in from.

Thank you so much.

Abdul

Sub Old_reply_1()
Dim objApp
Dim objInsp
Dim Mail As Outlook.MailItem
On Error Resume Next
Set objApp = GetObject("", "Outlook.Application")
If objApp Is Nothing Then
Set objApp = Application.CreateObject("Outlook.Application")
End If
Set objInsp = objApp.ActiveInspector.CurrentItem
If TypeName(objInsp) = "Nothing" Then
MsgBox "No inspector window found"
Exit Sub
Else
Set Mail = Outlook.CreateItem(olMailItem)
Dim myReply As Outlook.MailItem
Set myReply = objInsp.Reply
myReply.Display
With Mail
.To = objInsp.SenderEmailAddress & ";" & objInsp.To
.CC = objInsp.CC
.Subject = myReply.Subject
.Body = myReply.Body
.Display
End With
myReply.Close (olDiscard)
Set Mail = Nothing
objInsp = Nothing
End If
End Sub