Option Explicit

Sub CreateMessageFromTemplate()
Dim olApp As Object
Dim olItem As Object
Dim olInsp As Object
Dim wdDoc As Document
Dim oRng As Range
Dim oFrm As New UserForm1
Dim strName As String, strCase As String
Dim strTo As String
Const strWorkbook As String = "C:\Path\workbookname.xlsx"
Const strSheet As String = "Sheet1"

    On Error Resume Next

    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    With oFrm
        xlFillList .ComboBox1, 1, strWorkbook, strSheet, True, True, "[Select County]"
        .Show
        If .Tag = 0 Then GoTo lbl_Exit
        strTo = .ComboBox1.Column(1)
        strName = .TextBox1.Text
        strCase = .TextBox2.Text
    End With
    Unload oFrm

    Set olItem = olApp.CreateItemFromTemplate("C:\Path\Message.oft")
    With olItem
        .to = strTo
        .Subject = "The message subject"
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(FindText:="<Name>")
                oRng.Text = strName
                oRng.Collapse 0
            Loop
        End With
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(FindText:="<Case>")
                oRng.Text = strCase
                oRng.Collapse 0
            Loop
        End With
        .Display    'This line is required
        '.Send 'Restore this line after testing
    End With
lbl_Exit:
    Set olItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Function xlFillList(ListOrComboBox As Object, _
                            iColumn As Long, _
                            strWorkbook As String, _
                            strRange As String, _
                            RangeIsWorksheet As Boolean, _
                            RangeIncludesHeaderRow As Boolean, _
                            Optional PromptText As String = "[Select Item]")

Dim RS As Object
Dim CN As Object
Dim numrecs As Long, q As Long
Dim strWidth As String

    If RangeIsWorksheet = True Then strRange = strRange & "$]"

    Set CN = CreateObject("ADODB.Connection")


    If RangeIncludesHeaderRow Then
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                  "Data Source=" & strWorkbook & ";" & _
                                  "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Else
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                  "Data Source=" & strWorkbook & ";" & _
                                  "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"
    End If


    Set RS = CreateObject("ADODB.Recordset")
    RS.CursorLocation = 3

    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1    'read the data from the worksheet

    With RS
        .MoveLast
        numrecs = .RecordCount
        .MoveFirst
    End With

    With ListOrComboBox
        .ColumnCount = RS.Fields.Count
        If RS.RecordCount > 0 Then
            .Column = RS.GetRows(numrecs)
        End If

        strWidth = vbNullString
        For q = 1 To .ColumnCount
            If q = iColumn Then
                If strWidth = vbNullString Then
                    strWidth = .Width - 4 & " pt"
                Else
                    strWidth = strWidth & .Width - 4 & " pt"
                End If
            Else
                strWidth = strWidth & "0 pt"
            End If
            If q < .ColumnCount Then
                strWidth = strWidth & ";"
            End If
        Next q
        .ColumnWidths = strWidth
        If TypeName(ListOrComboBox) = "ComboBox" Then
            .AddItem PromptText, 0
            If Not iColumn - 1 = 0 Then .Column(iColumn - 1, 0) = PromptText
            .ListIndex = 0
        End If
    End With

    'Cleanup
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing

lbl_Exit:
    Exit Function
End Function