VBA Excel/Outlook: Forward an Outlook email from Excel and add text to the body

[BigShango]

Hi,

Been at this all day and finally having to admit defeat and refer to the experts.

I'm using this code to find a previously sent email in Outlook and display it ready to be forwarded on. All works great, but now I'm trying to get it to do the forwarding for me. I need to insert text from the textbox "ReminderBox", which is the wording for the body of my email.

The below code does this but it doesn't quite forward the email properly, it takes a copy of the original email and adds it after the body. I need to add the body in above the properly formatted forward message.

So where I have .Body = SurveysSheet.TextBoxes("ReminderBox").Text & .Body (taking the original body and adding ReminderBox before it, I need to do something like .Body = Insert(SurveysSheet.TextBoxes("ReminderBox").Text). If I just do .Body = SurveysSheet.TextBoxes("ReminderBox").Text it will replace the previous message, but adding &.Body doesn't quite have it in the right format (I want this to look exactly as though it has been done manually because I'm awkward like that! )

I hope I've explained this properly. Any help would be great, thanks.

Sub SendReminder2()' use this to search outlook and display found emails
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myitems = myInbox.Items
Set SurveysSheet = Workbooks(ActiveWorkbook.Name).Sheets("Surveys To Send")


MySubject = "ACT - Redeployment Survey"


For Row = 3 To SurveysSheet.Range("G" & Rows.Count).End(xlUp).Row
    MyRecip1 = Trim(SurveysSheet.Range("G" & Row).Value)
    MyRecip2 = Trim(SurveysSheet.Range("H" & Row).Value)
    SentDate = CDate(SurveysSheet.Range("I" & Row).Value)
    
    ' Loop through each item in MyItems starting with the newest
    ' Display email if firstname, lastname, subject and sent date match
    For I = myitems.Count To 1 Step -1
        If myitems(I).Class = olMail Then
            If InStr(1, myitems(I).To, MyRecip1) > 0 And InStr(1, myitems(I).To, MyRecip2) > 0 And InStr(1, myitems(I).SentOn, SentDate) And InStr(1, myitems(I).Subject, MySubject) > 0 Then
                MyTo = myitems(I).To
                Set MyForward = myitems(I).Forward
                With MyForward
                    .To = MyTo
                    .Body = SurveysSheet.TextBoxes("ReminderBox").Text & .Body
                    .Body = Replace(.Body, "Firstname", MyRecip1)
                    .Display
                End With
                GoTo ExitLoop
            End If
        End If
    Next I
ExitLoop:
Next Row


Set myOlApp = Nothing


End Sub

 

[BigShango]

If this isn't actually possible could someone tell me how to insert a horizontal line in the email?

Something like

 [COLOR=#333333].Body = SurveysSheet.TextBoxes("ReminderBox").Text & *HorizontalLine* &  .Body[/COLOR]