Userform in Outlook

[airwolf]

Evening all

Got a outlook userform which i'd like to make work.

The idea is that I have a combo box with different options in it (Counties) and that a different county corresponds to a different email address.

When I click the button it the pops up with the relevant to email address (for whichever county) I have selected.

The email will then populate the name and case number in the body of the email along with some other text.

Is anyone able to help?

Many Thanks

Ian

[gmayor]

There is nothing particularly complex about your request, though you have not indicated where the data is to come from. Note a combobox is intended to display a single item from the contents. If you want to show more than one item, use a list box.

An Excel worksheet is probably the best place to hold the data, but if there are only a few counties to list, you can store them in the macro code.

Although aimed at Word, the principles at http://www.gmayor.com/Userform_ComboBox.html are the same for Outlook.

Writing directly to the body of an e-mail requires a knowledge of Word ranges, but a simple workaround is to create a message template that contains your message text with a couple of tags for the name and case number items from the form i.e. <Name> and <Case> which can be repaced from the form data. You can use the following as a basis for the code to create the message, which uses the xlfilllist function from the linked web page to fill the userbox from a two column Excel sheet which has the counties and the email addresses, with a header row.

Option Explicit

Sub CreateMessageFromTemplate()
Dim olItem As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
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"
    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 = Application.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

The userform code is simply as follows with CommandButton1 being the Continue button and CommandButton2 the Cancel button. I have used default names. You should use more meaningful names for the variopus elements.

Option Explicit

Private Sub CommandButton1_Click()
    Me.Hide
    Me.Tag = 1
lbl_Exit:
    Exit Sub
End Sub

Private Sub CommandButton2_Click()
    Me.Hide
    Me.Tag = 0
lbl_Exit:
    Exit Sub
End Sub

[airwolf]

Thanks - sounds really helpful.

I dont have macros enabled within my outlook so I cant test it at home - but I will be able to at work!!!

I think a list box will probably work then and then have the background data stored in an excel worksheet somewhere.

That part of code which starts Option Explicit, does that go in the commandbutton1 or the listbox? (im going to change from combo to list).

Many Thanks

Ian

[gmayor]

The second block of code goes in the userform. The rest goes in an ordinary module.

Don't forget the ExcelFillList function from my web site. That goes in a separate ordinary module.

It will work with a list box or a combobox. The list box doesn't use the prompt text. However as you are only selecting one item from the list, the combobox would probably make more sense.

[airwolf]

My outlook has crashed on me so going to try it in word using the same userform.

Got a little error message come up - see screen shot.

Ive created a template and spreadsheet and put them both in the d:\ drive and called them both test.

[gmayor]

The posted code is for Outlook. It will not work in Word without modification - see below, however it still requires Outlook to create the message, so if Outlook has crashed, you need to investigate why. The following Word version includes the Excel function.

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

[airwolf]

Evening - Been playing around with it - can get the userform up but it doesnt link to my excel worksheet nor does the email template open.

Its just a blank email with a Subject and some text in the body.

Are you able to spot where I am going wrong?

Many Thanks

[gmayor]

The worksheet needs to be in XLSX format for the function to work. Also you did not include your e-mail message template. I noticed also that Outlook would not reliably start from the code so I have added a trap to ensure that Outlook is running before running the code:

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