Edit Outlook locally saved .msg body by replacing text in VBA

Good afternoon,

I have an Outlook .msg email saved at a local folder in my computer.

Is there any way I can replace the word "AAAA" in the body with any word I want in VBA? Is there any way I can change the To: field?

The goal is to run an Excel table and create copies of a template message, replace the To: field and some words of the template with the info in the Excel table and save it. We will manually send latter.

I only need the .msg file modifying code (To: field and body replaces). The loop is already coded.

Thank you so much,

If anyone needs, here it is the code I used. Do not focus on the for loops, but in the way the msg is loaded, edited and saved.

In this example some words in the msg file are replaced for the values in an excel table, as well as the TO: (email receiver). e.g. word AA in a msg file is changed with the value of the C7 cell.

The aim is to create a msg as a template with some key words (AA, BB, CC, etc), copy that template, replace those words with the ones in the excel table and save the new msg file.

Sub Recorrer()

    Dim x As Integer
    Dim fsObject As Object

    Dim outApp As Object 'Outlook.Application
    Dim outEmail As Object 'Outlook.MailItem
    Dim outRecipient As Object 'Outlook.Recipient

    On Error Resume Next
        Set outApp = GetObject(, "Outlook.Application")
        If outApp Is Nothing Then
            MsgBox "Outlook is not open"
            Exit Sub
        End If

    On Error GoTo 0

    Set fsObject = CreateObject("Scripting.FileSystemObject")


    ' Set numcols = number of cols to be replaced.
    NumCols = Range("C1", Range("C1").End(xlToRight)).Cells.Count
    ' Set numrows = number of rows of data.
    NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count

    ' Select cell a1.
    Range("A2").Select

    ' Establish "For" loop to loop "numrows" number of times.

    For x = 1 To NumRows

        fsObject.CopyFile ThisWorkbook.Path & "\" & Range("B" & x + 1) & ".msg", ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg"

        Set outEmail = outApp.Session.OpenSharedItem(ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg")

        outEmail.Recipients.Add Range("A" & x + 1)

        For Z = 1 To NumCols

            'MsgBox Cells(x + 1, Z + 2)
            outEmail.HTMLBody = Replace(outEmail.HTMLBody, Cells(1, Z + 2), Cells(x + 1, Z + 2))
        
        Next

    outEmail.Save

    ' Selects cell down 1 row from active cell.
    ActiveCell.Offset(1, 0).Select

    Next

End Sub