How to add an attachment in VBA with Outlook.Application

I have succeeded with this method:
Public Sub SendMailWithOutlook()
Dim objMessage As Object  'Outlook.MailItem
Dim objOutlook As Object  'Outlook.Application

    On Error GoTo ErrHandler
   
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMessage = objOutlook.CreateItem(0)  '(olMailItem)

    With objMessage
        If Len(Trim$(AddressTo)) = 0 Then
            .recipients.Add " "  '"someone@somewhere.com"
        Else
            .recipients.Add AddressTo
        End If
        .Subject = Subject
        .Body = Body
        .Attachments.Add Attachments
        .Display
    End With
    Set objMessage = Nothing
    Set objOutlook = Nothing
   
    Exit Sub
   
ErrHandler:
    If Err.Number = -2147024894 Then
        MsgBox "An error occured while trying to attach " & Attachments & " to the e-mail!!!" & _
               vbCrLf & vbCrLf & _
               "Error: " & Err.Number & ": " & Err.Description
    Else
        MsgBox "An error occured while trying to prepare an e-mail!!!" & _
               vbCrLf & vbCrLf & _
               "Error: " & Err.Number & ": " & Err.Description
    End If
End Sub

hearing...

Here is some code I got from EE long ago that works:

Add two references to your VB project Microsoft Data Access Objects(DAO) and Microsoft Outlook Object Library. You will also need to create the two forms and add their respective controls. You can paste the code into your form.


Private dbs As Database
Private rst As Recordset


Private Sub cmdSendEmail_Click()
    'I remmed out the error handler because I don't have the RSS constant
    'or the errMonitor Sub
    'On Error GoTo cmdSendEmail_ClickError
     
    Dim xemail As Integer
    Dim intreturned
    Dim Msg As String
     
    ' Return reference to current database.
    '+++++++++++ Replace the path to the mdb with the true path +++++++
    Set dbs = DBEngine.Workspaces(0).OpenDatabase("C:\My Documents\db2.mdb")
    Set rst = dbs.OpenRecordset("tblEmails_to_go")
     
    'The DCount Function Doesn't exist in VB - That's why we
    'Set the rst before beginning the email routine
    'It's good to check if there are records before moving to the last one
    If (rst.BOF And rst.EOF) Then Exit Sub
     
    ' Populate Recordset object.
    rst.MoveLast
     
    xemail = rst.recordcount
     
     
    'This should all look pretty familiar
    intreturned = MsgBox("Send e-mail selected.  If you continue," & Chr(13) & Chr(10) _
    & xemail & " e-mail messages will be queued for sending!", vbOKCancel + vbQuestion + vbDefaultButton2, "Send E-mail")
   
    Select Case intreturned
        Case vbOK:
            'always dots (.) not bangs (!) for control references
            'VB textboxes never contain the value Null so we check len instead
            If Len(Me.fraAttachment) = 0 Then
                SendMessage False
            Else
                If Me.fraAttachment = "1" Then
                    SendMessage False, "c:\Resident\Notice.doc"
                End If
                If Me.fraAttachment = "2" Then
                    SendMessage False, "c:\Resident\Notice.txt"
                End If
                If Me.fraAttachment = "3" Then
                    SendMessage False
                End If
            End If
        Case vbCancel:
            Close
        Case Else
    End Select
   
   
cmdSendEmail_ClickExit:
    Exit Sub

'I remmed out the error handling stuff because I don't have a sub errMonitor
'or a const RSS
cmdSendEmail_ClickError:
    'MsgBox Error$, 16, RSS
    'Call errMonitor("ErrorHandler.errMonitor")
    'Resume cmdSendEmail_ClickExit
End Sub

Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
   
    'On Error GoTo SendMessageError
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim counter
   
    'No nulls again and dots not bangs
    If Len(Me.txtSubject.Text) = 0 Then
        MsgBox "You must enter a subject before despatching e-mails!"
        Me.txtSubject.SetFocus
        Exit Sub
    End If
   
    If Len(Me.txtNotice.Text) = 0 Then
        MsgBox "You must enter text before despatching e-mail!"
        Me.txtNotice.SetFocus
        Exit Sub
    End If
     
    'The opening of the recordset got pushed up to the click event
    'otherwise this should be familiar
   
     rst.MoveLast
    'progress meter form code follows - down to next remark
    'and then further towards bottom
     
    ' .Show rather than DoCmd, I love VB!
    frmProgress.Show
    Dim f As frmProgress
    Set f = frmProgress
    f.Prog.Max = rst.recordcount
    'progress meter form code above
    rst.MoveFirst
   
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    Do While Not rst.EOF
        ' Create the message.
        Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
         
        With objOutlookMsg
            ' Add the To recipient(s) to the message.
            'Set objOutlookRecip = .Recipients.Add(Me![txtemailaddress])
            Set objOutlookRecip = .Recipients.Add(rst!emailaddress)
             
            objOutlookRecip.Type = olTo
       
       
            ' Set the Subject, Body, and Importance of the message.
            .Subject = Me.txtSubject.Text
            .Body = Me.txtNotice.Text
            .Importance = olImportanceHigh  'High importance
             
            ' Add attachments to the message.
             
            If Not IsMissing(AttachmentPath) Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If
       
            ' Should we display the message before sending?
            If DisplayMsg Then
                .Display
            Else
                .Send
            End If
        End With
     
        counter = counter + 1
         
        'progress meter code follows "down to next remark
        'and then a little further down too
        f.Prog.Value = counter
        'progress meter code above
         
        rst.MoveNext
    Loop
    Set objOutlook = Nothing
   
    'progress meter code below
    Unload f
    'progress meter code above and ends here
     
    MsgBox "" & counter & " e-mail messages have been placed in your outbox!"
    rst.Close
   
SendMessageExit:
    Exit Sub

SendMessageError:
    'MsgBox Error$, 16, RSS
    'Call errMonitor("ErrorHandler.errMonitor")
    'Resume SendMessageExit
End Sub

Any progress?

???

This question appears to be abandoned. A question regarding it will be left in the CleanUp
area; if you have any comment about the question, please leave it here.

Unless there is objection or further activity, one of the moderators will be asked to accept the comment
of <hongjun>.

DO NOT ACCEPT THIS COMMENT AS AN ANSWER.