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 = "D:\text.xlsx"
Const strSheet As String = "Sheet1"

    On Error Resume Next

    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Err.Clear
        MsgBox "Start Outlook and run the macro again"
        GoTo lbl_Exit
    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("D:\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