XL2000: How to Send Form Mail That Uses Excel Data

'--- Set up the Outlook objects.
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment

'--- Declare our global variables to be used in each subroutine.
Dim CustomerAddress As String
Dim CustomerMessage As String

Sub MailItNow()

'--- Declare our variables.
Dim X As Integer
Dim TempCustomerAddress As String

'--- Prevent screen redraws until the macro is finished.
Application.ScreenUpdating = False

'--- Sort the addresses and names alphabetically, by the e-mail address.
'--- This is REQUIRED to prevent any duplicate addresses from
'    receiving more than one e-mail.
 
Columns("A:B").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'--- Sets which row to start searching for e-mail addresses and names.
X = 2

'--- Begin looping through all the e-mail addresses in column A until
'    a blank cell is hit.
While Range("A" & X).Text <> ""

    '--- These variables will be used to search for duplicates.
    CustomerAddress = Range("A" & X).Text
    TempCustomerAddress = CustomerAddress
       
    '--- Increment X until a different e-mail address is found.
    While TempCustomerAddress = CustomerAddress
        X = X + 1
        CustomerAddress = Range("A" & X).Text
    Wend
    
    '--- Add the e-mail address to a global variable.
    CustomerAddress = Range("A" & X - 1).Text
    '--- Add a message with the user's name to the e-mail.
    '--- Customize your own message and closing here.
    CustomerMessage = Range("B" & X - 1).Text & "," & vbCrLf & vbCrLf _
       & "Thank you for trying our product!" & vbCrLf & vbCrLf & _
       "Sincerely," & vbCrLf & "ProductCo Inc."
        
    '--- Run the subroutine to send the message.
    Call SendMessage

Wend

End Sub

Sub SendMessage(Optional AttachmentPath)
    
    '--- This is required to prevent a name which does not resolve to
    '    an e-mail address from hanging the app.
    On Error Resume Next
    
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    With objOutlookMsg
        ' Add the To recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add(CustomerAddress)
        objOutlookRecip.Type = olTo
        
        ' Set the Subject, Body, and Importance of the message.
        .Subject = "Thank You!"
        .Body = CustomerMessage
        .Importance = olImportanceHigh  'High importance
        
        ' Add attachments to the message.
        If Not IsMissing(AttachmentPath) Then
            Set objOutlookAttach = .Attachments.Add(AttachmentPath)
        End If
        
        ' Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
            If Not objOutlookRecip.Resolve Then
            Exit Sub
        End If
        Next
        .Send '--- Send the message.
    
    End With
    
    '--- Remove the message and Outlook application from memory.
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing
End Sub