vba replacing a text placeholder

[Loadius]

Hey all, Hopefully someone can help me. I am trying to call an Outlook template with predefined headers and footers, with a range of cells. To do this, I have a placeholder called rngText. I have created the below code.

Sub Open_Email()

'Create email template
    Dim objOL As Object
    Dim Msg As Object
Dim olInsp As Object 'Outlook.Inspector
Dim wd As Object 'Word.Document

Set objOL = CreateObject("Outlook.Application")
Set mail_Object = CreateObject("Outlook.Application")
Inpath = "\\xxxxxxxxxxxxxxxxxx\aaaaaaaaaaaa"

thisFile = Dir(Inpath & "\*5.oft")

Do While thisFile <> ""
Set Msg = objOL.Session.OpenSharedItem(Inpath & "\" & thisFile)

        thisFile = Dir
Loop
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
End With

'create the range of cells to replace into email template

     With Msg
      Dim dataSheet As Worksheet
    Set dataSheet = ActiveWorkbook.Worksheets("Report")

  Dim HtmlBody As String
  Dim reprngText As String: reprngText = dataSheet("A1:E70").Value
   Dim replaceStrings() As Variant
   Dim replaceWithStrings() As Variant
   replaceStrings = Array("rngText")
   replaceWithStrings = Array(reprngText)
   Dim currentItem As String
   Dim currentReplaceItem As String
   Dim i As Integer
    i = UBound(replaceStrings)
    Dim j As Integer
    j = 0

   End With

    On Error Resume Next

     With Msg

    Today = Format(Now(), "DDDD DD MMM yyyy")

     Msg.Subject = "Report " & Today
             Do Until j = i + 1

            .HtmlBody = Replace(.HtmlBody, replaceStrings(j), replaceWithStrings(j))
        j = j + 1
        Loop

   Msg.Display             
   Debug.Print Msg.HtmlBody
   .Display
    End With
    With Application
        .EnableEvents = True
        .ScreenUpdating = False
            On Error GoTo 0
    End With
    Set OutMail
    Set OutApp = Nothing

 End Sub

 

[Monty]

Try this code modified

Sub Open_Email()
    ' Create email template
    Dim objOL As Object
    Dim Msg As Object
    Dim olInsp As Object 'Outlook.Inspector
    Dim wd As Object 'Word.Document
    Dim mail_Object As Object
    
    Set objOL = CreateObject("Outlook.Application")
    Set mail_Object = CreateObject("Outlook.Application")
    
    Inpath = "\\xxxxxxxxxxxxxxxxxx\aaaaaaaaaaaa"
    thisFile = Dir(Inpath & "\*5.oft")
    
    Do While thisFile <> ""
        Set Msg = objOL.Session.OpenSharedItem(Inpath & "\" & thisFile)
        thisFile = Dir
    Loop
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    ' Create the range of cells to replace into email template
    Dim dataSheet As Worksheet
    Set dataSheet = ActiveWorkbook.Worksheets("Report")
    Dim rngText As Range
    Set rngText = dataSheet.Range("A1:E70")
    Dim reprngText As String
    reprngText = rngText.Value
    
    Dim replaceStrings() As Variant
    Dim replaceWithStrings() As Variant
    
    replaceStrings = Array("rngText")
    replaceWithStrings = Array(reprngText)
    
    Dim currentItem As String
    Dim currentReplaceItem As String
    Dim i As Integer
    i = UBound(replaceStrings)
    Dim j As Integer
    j = 0
    
    On Error Resume Next
    
    With Msg
        Today = Format(Now(), "DDDD DD MMM yyyy")
        .Subject = "Report " & Today
        
        Do Until j = i + 1
            .HtmlBody = Replace(.HtmlBody, replaceStrings(j), replaceWithStrings(j))
            j = j + 1
        Loop
        
        .Display
        Debug.Print .HtmlBody
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = False
        On Error GoTo 0
    End With
    
    Set OutMail
    Set OutApp = Nothing
End Sub