Solved Replace Function, Mail Merge Preview Email Template (1 Viewer)

[trevermah]

Hi there, I'm working on a Email Template maker for part of my contact database. I have a working prototype that will work but for any additional merge fields will involve a lot of editing in multiple places. Right now users can create a new Email Body which they can add merge fields (using a list box) which is based off a table i've created with 3 Columns ID, MERGEFIELDS and EXAMPLES.

1 | %FIRSTNAME% | John
2 | %LASTNAME% | Abraham

The preview involves me having to use the Replace function but it has to be maintained each time another merge field is added. I use the following code in a Textbox control.

=Replace(Replace(Replace(Replace([EmailBody],"%FIRSTNAME%","John"),"%LASTNAME%","Abrahams"),"%STAFFID%","abrahamsj"),"%MONTH%","December")

Here's a little snippet of what I'm working with.

2 Questions: Is there a way of replacing the fields faster (through the use of a current recordset, and or table?)

Is there a way of converting the HTML codes to preview as a HTML style in the preview?

Thank you for any help, links, or guidance.

 

[Uncle Gizmo]

I'm bumping your message up the list so that it gets another look...

 

[trevermah]

Thanks. Ill post the code for my email that replaces the merge fields. I'm thinking of looking through the tblMergeFields which has the naming convention of what should be found that needs to be replaced.


I was also thinking it would be a function that has a loop to replace the text but was unsure where to start on how to build it.

 

[arnelgp]

for q1:

Private Sub send_button_Click()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim fld As DAO.Field
    Dim strBody As String
    Dim i As Integer
    
    Dim arrFields() As String
    ReDim arrFields(1 To 500)
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(Me!SQLRecordSource, dbOpenSnapshot, dbReadOnly)
    With rst
        If Not (.BOF And .EOF) Then
            For Each fld In .Fields
                If (fld.Type > 100) Or ((fld.Attributes And dbAutoIncrField) > 0&) Then
                    'do nothing
                Else
                    i = i + 1
                    arrFields(i) = fld.Name
                End If
            Next
            ReDim Preserve arrFields(1 To i)
        End If
        Do Until .EOF
            strBody = Me!EmailBody
            For i = 1 To UBound(arrFields)
                strBody = Replace$(strBody, "%" & arrFields(i) & "%", .Fields(arrFields(i)))
            Next
            ' your email code here
            ' outlook.mail.htmlbody = strbody
            .MoveNext
        Loop
        .Close
    End With
    Set rst = Nothing
    Set dbs = Nothing
End Sub

for q2, use, (Property Sheet->Data->Text Format: Rich Text

 

[trevermah]

for q1:

Private Sub send_button_Click()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim fld As DAO.Field
    Dim strBody As String
    Dim i As Integer
   
    Dim arrFields() As String
    ReDim arrFields(1 To 500)
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(Me!SQLRecordSource, dbOpenSnapshot, dbReadOnly)
    With rst
        If Not (.BOF And .EOF) Then
            For Each fld In .Fields
                If (fld.Type > 100) Or ((fld.Attributes And dbAutoIncrField) > 0&) Then
                    'do nothing
                Else
                    i = i + 1
                    arrFields(i) = fld.Name
                End If
            Next
            ReDim Preserve arrFields(1 To i)
        End If
        Do Until .EOF
            strBody = Me!EmailBody
            For i = 1 To UBound(arrFields)
                strBody = Replace$(strBody, "%" & arrFields(i) & "%", .Fields(arrFields(i)))
            Next
            ' your email code here
            ' outlook.mail.htmlbody = strbody
            .MoveNext
        Loop
        .Close
    End With
    Set rst = Nothing
    Set dbs = Nothing
End Sub

for q2, use, (Property Sheet->Data->Text Format: Rich Text

Thanks arnelgp for this. I'm having a subscript out of range error on the line "ReDim Preserve arrFields(1 to i)"

I've copied my existing code below for reference.

Private Sub Command150_Click()
    Dim objOutlook As Object
    Dim objOutlookMsg As Object
    Dim ds As DAO.Database
    Dim rs As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim fld As DAO.Field
    Dim i As Integer
    Dim EmailSubject As String
    Dim EmailBodyTemplate As String
    Dim EmailBody As String
    Dim strTo, strSignature As String
    Dim arrFields() As String
    ReDim arrFields(1 To 500)
    MsgBoxPromptDebug "Starting Email Template Process"
    'On Error Resume Next
    Set db = CurrentDb
    Set rs = db.OpenRecordset("" & DLookup("qryRecordSource", "tblEmailTemplates", "ID=" & Me.ID) & "", dbOpenDynaset) ' Uses field for record source from tblEmailTemplate
    rs.MoveFirst
    rs.MoveLast
    Debug.Print rs.RecordCount & "records to process through"
    Set rs2 = db.OpenRecordset("SELECT tblMergeFields.MERGEFIELD FROM tblMergeFields", dbOpenSnapshot, dbReadOnly)
    EmailBody = DLookup("EmailBody", "tblEMailTemplates", "ID=" & Me.ID) ' Pulls subject from tblEmailTemplate
    EmailSubject = DLookup("EmailSubject", "tblEMailTemplates", "ID=" & Me.ID) ' Pulls subject from tblEmailTemplate
    With rs2
        If Not (.BOF And .EOF) Then
            For Each fld In .Fields
                If (fld.Type > 100) Or ((fld.Attributes And dbAutoIncrField > 0)) Then
                    'nothing
                Else
                    i = i + 1
                    arrFields(i) = fld.Name
                End If
            Next
            ReDim Preserve arrFields(1 To i)
        End If
        Do Until rs.EOF
            strTo = rs!EmailAddress
            For i = 1 To UBound(arrFields)
                EmailBody = Replace$(EmailBody, "%" & arrFields(i) & "%", .Fields(arrFields(i)))
                EmailSubject = Replace$(EmailSubject, "%" & arrFields(i) & "%", .Fields(arrFields(i)))
            Next
            Set objOutlook = CreateObject("Outlook.Application") ' Create the Outlook session.
            Set objOutlookMsg = objOutlook.CreateItem(0) ' Create the message.
            With objOutlookMsg                   ' Sets Parameters for new outlook message
                .Display
            End With
            strSignature = objOutlookMsg.HTMLBody ' Adds signature from account
            With objOutlookMsg                   ' Sets Parameters for new outlook message
                .BodyFormat = olFormatHTML
                If DLookup("[EmailToDebug]", "tblUserAccountSettings") = -1 Then
                    .To = DLookup("[txtEmailSendToDebug]", "tblUserAccountSettings") ' Assigns the DebugSendTo Email Address
                Else
                    .To = strTo                  ' Assigns the original TO Address
                End If
                .To = rs!EmailAddress
                .CC = ""
                .Subject = EmailSubject
                .HTMLBody = "<font face=Calibri, size=10pt>" & EmailBody & "</font>"
                .HTMLBody = EmailBody & strSignature
                'pdfFile = Dir(pdfPath & "*.pdf")
                'While pdfFile <> ""
                '    .Attachments.Add pdfPath & pdfFile
                '    pdfFile = Dir
                'Wend
                .Save
                '.Display
                '.Send 'sends the email automatically without interaction. Comment to stop sending
                x = x + 1                        '   Counter for # of emails sent"
                rs.MoveNext
            End With
            Pause (Nz(DLookup("numTimeBetweenEmails", "tblSettings"), 0)) ' Pauses for x number of seconds based off another table for settings
            Debug.Print "Pausing for " & (Nz(DLookup("numTimeBetweenEmails", "tblSettings"), 0)) & " seconds."
        Loop
        .Close
    End With
    Set rs = Nothing
    Set rs2 = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing
    Set db = Nothing
End Sub

 

[Gasman]

So i is likely zero?
Follow the code to see what it is doing with F8 in the debug window.

 

[trevermah]

So i is likely zero?
Follow the code to see what it is doing with F8 in the debug window.

yes i = 0

 

[Gasman]

yes i = 0

So how can you redim 1 to 0 ?

 

[trevermah]

So how can you redim 1 to 0 ?

i suppose you can't. I've changed it to (0 to i) but the same error occurs. I didn't originally produce the code as it was provided as an option for my initial question. I'll try and break it up into a small database later and upload it without any important information.

I don't think it's finding my fields properly.
this is what i see hovering over fld.name

"Fld.Name = <Object variable or With block variable not set>"

 

[Gasman]

The point I am trying to make is that you still need to understand any code you are given?, otherwise you are no further forward.

I will not pretend to understand all the code, but I would likely only Increment i when needed, THEN Redim() and then assign to the array.

HTH

 

[trevermah]

I ended up figuring it out since the If statement i think wasn't checking properly. so i move the i = i + 1 to the area where 'nothing was listed.

Private Sub EmailTemplateWithMergeFields_Click()
Dim objOutlook As Object
    Dim objOutlookMsg As Object
    Dim ds As DAO.Database
    Dim rs As DAO.Recordset
    Dim fld As DAO.Field
    Dim i As Integer
    Dim EmailSubject As String
    Dim EmailBodyTemplate As String
    Dim EmailBody As String
    Dim strTo, strSignature As String
    Dim arrFields() As String
    MsgBoxPromptDebug "Starting Email Template Process"
    On Error Resume Next
    ReDim arrFields(1 To 500)
    Set db = CurrentDb
    Set rs = db.OpenRecordset("" & DLookup("qryRecordSource", "tblEmailTemplates", "ID=" & Me.ID) & "", dbOpenSnapshot, dbReadOnly) ' Uses field for record source from tblEmailTemplate
    Set objOutlook = CreateObject("Outlook.Application") ' Create the Outlook session.
    Debug.Print rs.RecordCount & " records to process through"
    With rs
        Do Until rs.EOF
            If Not (rs.BOF And rs.EOF) Then
                For Each fld In rs.Fields
                    If (fld.Type > 100) Or ((fld.Attributes And dbAutoIncrField) > 0) = True Then
                        'nothing
                        Debug.Print "Nothing"
                    Else
                        i = i + 1
                        Debug.Print i & " - " & rs.Fields(fld.Name)
                        arrFields(i) = fld.Name
                    End If
                Next
                ReDim Preserve arrFields(1 To i)
            End If
       
            strTo = rs!EmailAddress
            EmailBody = DLookup("EmailBody", "tblEMailTemplates", "ID=" & Me.ID) ' Pulls subject from tblEmailTemplate
            EmailSubject = DLookup("EmailSubject", "tblEMailTemplates", "ID=" & Me.ID) ' Pulls subject from tblEmailTemplate
            For i = 1 To UBound(arrFields)
                EmailBody = Replace$(EmailBody, "%" & arrFields(i) & "%", .Fields(arrFields(i)))
                EmailSubject = Replace$(EmailSubject, "%" & arrFields(i) & "%", .Fields(arrFields(i)))
            Next
            Set objOutlookMsg = objOutlook.CreateItem(0) ' Create the message.
            With objOutlookMsg                   ' Sets Parameters for new outlook message
                .Display
                .BodyFormat = olFormatHTML
            End With
            strSignature = objOutlookMsg.HTMLBody ' Adds signature from account
            With objOutlookMsg                   ' Sets Parameters for new outlook message
                If DLookup("[EmailToDebug]", "tblUserAccountSettings") = -1 Then
                    .To = DLookup("[txtEmailSendToDebug]", "tblUserAccountSettings") ' Assigns the DebugSendTo Email Address
                Else
                    .To = strTo                  ' Assigns the original TO Address
                End If
                .CC = ""
                .Subject = EmailSubject
                .HTMLBody = "<font face=Calibri, size=10pt>" & EmailBody & "</font>"
                .HTMLBody = EmailBody & strSignature
                'pdfFile = Dir(pdfPath & "*.pdf")
                'While pdfFile <> ""
                '    .Attachments.Add pdfPath & pdfFile
                '    pdfFile = Dir
                'Wend
                .Save
                '.Display
                '.Send 'sends the email automatically without interaction. Comment to stop sending
            End With
            x = x + 1                            '   Counter for # of emails sent"
            .MoveNext
        Loop
        Pause (Nz(DLookup("numTimeBetweenEmails", "tblSettings"), 0)) ' Pauses for x number of seconds based off another table for settings
        Debug.Print "Pausing for " & (Nz(DLookup("numTimeBetweenEmails", "tblSettings"), 0)) & " seconds."
        .Close
    End With
    MsgBox x
    Set rs = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing
    Set db = Nothing
End Sub

Note that this does not work with queries that have parameters like passing a temp variable. I'm not sure why but it doesn't work.

 

[Gasman]

Again, how can you add a value to array() when it has not been increased in size to accommodate the new value??

 

[trevermah]

Hi Gasman, I found an issue with the last code (one my loop didn't work, and even though it was adding values it was still causing problems). I've pasted the new version in my edited comment above.

I had to adjust my brackets for

If (fld.Type > 100) Or ((fld.Attributes And dbAutoIncrField) > 0) Then

and move it back to the else portion of the statement. Stepping through the code I could see it was adding additional i values as it needed that were found from my query.

Thanks again for the guidance.