Multiple Email Attachments

smbarney · Nov 5, 2009

I am using the follow code to send emails from Access 2003 to Outlook 2003. It works fine. Now, however, I need to be able send to multiple attachments that the user selects from a sub-form. Does anyone know how I modify this function to attach 0 to many attachments based on the input from a sub-form?

I've tried for two days and can't get it to work. Help would be much appreciated. Thanks

Code:

Public Function SendMessage(varTo As Variant, strSubject As String, strBody As String, _
     bolAutoSend As Boolean, bolSaveInOutbox As Boolean, bolAddSignature As Boolean, _
    Optional varCC As Variant, Optional varBCC As Variant, Optional varReplyTo As Variant, Optional varAttachmentPath As Variant, Optional varImagePath As Variant, Optional varHtmlFooter As Variant) As Boolean
'=================================================================
'
'varto: a string of email addresses, multiples delimted by semi-colon
'strSubject: subject line for the email
'strBody: body of the email, must be wrapped in <html> </html> tags, and optionally any other formatting tags
'bolAutoSend: determines whether email is sent automatically or displayed to the user
'bolSaveInOutbox: determines if the message is saved in the outbox
'boladdsignature: determines if the user's default signature is added to the outgoing email
'varCC: (Optional) CC email addresses, multiples delimited by semi-colon
'varBCC: (Optional) BCC email addresses, multiples delimited by semi-colon
'varReplyTo (Optional) If specified sets the reply to email address, multiples delimited by semi-colon
'varAttachmentPath: (Optional) If specified attaches the file
'varImagePath: (Optional) If specified embeds the image in the body of the email
'varHtmlFooter: (Optional) If specifed, inserts an html file as a footer to the message.
'ASSUMPTIONS: Outlook, HTML message format, Word is the default editor
'When performing some of the optional steps the message is constructed in the following order
'signature then embedded image then footer then body text, so the actual email would read as follows
'body text, footer, embedded image, signature
'=================================================================
On Error GoTo HandleError

Dim i As Integer
Dim strtempfile As String
Dim strmsg As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objInsp As Outlook.Inspector
Dim objWord As Word.Application
Dim objdoc As Word.Document
Dim objrange As Word.Range

SendMessage = False

Set objOutlook = New Outlook.Application                                'Create the Outlook session.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)                   'Create the message.

strBody = ReplaceCRLFwithBR(strBody)                                    'Replace any vbcrlf with <br>

If (InStr(strBody, "<font") = 0) Or (InStr(strBody, "<html>") = 0) Then                              'if no <html> and <font> tags then wrap the body of the message with these tags
    strBody = FormatAsHtml(strBody)
End If

With objOutlookMsg
    
    If Not IsMissing(varTo) Then
        If varTo <> "" And Not IsNull(varTo) Then
            For i = 1 To CountCSWords(varTo)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varTo, i))               'Add the TO recipient(s) to the message.
                objOutlookRecip.Type = olTo
            Next i
        End If
    End If

    If Not IsMissing(varCC) Then
        If varCC <> "" And Not IsNull(varCC) Then
            For i = 1 To CountCSWords(varCC)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varCC, i))                  'Add the cc recipient(s) to the message.
                objOutlookRecip.Type = olCC
            Next i
        End If
    End If
  
    If Not IsMissing(varBCC) Then
        If varBCC <> "" And Not IsNull(varBCC) Then
            For i = 1 To CountCSWords(varBCC)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varBCC, i))                 'Add the bcc recipient(s) to the message.
                objOutlookRecip.Type = olBCC
            Next i
        End If
    End If
    
    If Not IsMissing(varReplyTo) Then
        If varReplyTo <> "" And Not IsNull(varReplyTo) Then
            For i = 1 To CountCSWords(varReplyTo)
                Set objOutlookRecip = .ReplyRecipients.Add(GetCSWord(varReplyTo, i))        'Add the bcc recipient(s) to the message.
            Next i
        End If
    End If
    
    
    If (Not IsMissing(varAttachmentPath)) Then                                                      'if attachment is specified
        If (varAttachmentPath <> "") And (Not IsNull(varAttachmentPath)) Then                       'check it is valid
            If Dir(varAttachmentPath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then    'check the file actually exists
                Set objOutlookAttach = .Attachments.Add(CStr(varAttachmentPath))                      'Add attachments to the message.
            End If
        End If
    End If
    
    
    .Subject = strSubject               'Set the Subject of the message.

    .BodyFormat = olFormatHTML          'set format to html
    
    If bolAddSignature Or Not IsMissing(varImagePath) Or Not IsMissing(varHtmlFooter) Then  'if signature or embedded image or html footer
        Set objInsp = objOutlookMsg.GetInspector                                            'this causes the default signature to be added to the message
        Set objdoc = objInsp.WordEditor
        If objdoc Is Nothing Then
            strmsg = "Outlook must use Word as the email editor. Follow these instructions to fix the problem." & vbCrLf & vbCrLf & _
                "Tools>Options" & vbCrLf & "Then select 'Mail Format' tab" & vbCrLf & "Ensure Use Microsoft Office Word 2003 to edit e-mail messages."
            MsgBox strmsg
            objOutlookMsg.Close olDiscard
            GoTo SendMessage_Done
        End If
            
        Set objWord = objdoc.Application
        
        If bolAddSignature = False Then         'If the user had a signature it would have been applied, if we dont want it then we need to delete it here
            objdoc.Range.Delete
        End If
            
        If Not IsMissing(varImagePath) Then
            If varImagePath <> "" And Not IsNull(varImagePath) Then
                If Dir(varImagePath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
                    On Error Resume Next
                    .Display                                                                        'Seems like word document must be visible before you can use addpicture method
                    If Err <> 0 Then            'if the mail cound not be displayed then display a warning and discard the message
                        MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
                        .Close olDiscard
                        GoTo SendMessage_Done
                    End If
                    objWord.WindowState = wdWindowStateMinimize                                     'minimize word application so user does not see mail being created
                    Set objrange = objdoc.Range(start:=0, End:=0)                                   'goto start of message again
                    objrange.InsertBefore vbCrLf
                    objdoc.InlineShapes.AddPicture fileName:=varImagePath, LinkToFile:=False, SaveWithDocument:=True, Range:=objrange
                End If
            End If
        End If

        If Not IsMissing(varHtmlFooter) Then
            If varHtmlFooter <> "" And Not IsNull(varHtmlFooter) Then
                If Dir(varHtmlFooter, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
                    Set objrange = objdoc.Range(start:=0, End:=0)                                   'goto start of message
                    objrange.InsertFile varHtmlFooter, , , False, False   'insert the html from the external file
                End If
            End If
        End If
        
        strtempfile = Environ("temp") & Format(Now(), "yyyymmddhhnnss") & ".htm"        'generate temp filename
        Set objrange = objdoc.Range(start:=0, End:=0)                                   'goto start of message again
        CreateTextFile strtempfile, strBody                                             'save the bodytext as a temporary htm file
        objrange.InsertFile strtempfile, , , False, False                               'insert the htm file into the body of the message
        Kill strtempfile                                                                'delete temp file
        
        objdoc.SpellingChecked = True                                                   'doesnt matter for autosend, but helps the user if the message is being displayed
    Else
        .HTMLBody = strBody
    End If
    
    If bolSaveInOutbox = False Then             'if message not to be saved after sending
        .DeleteAfterSubmit = True               'specify that it should be deleted
    End If
        
    If (bolAutoSend = True) And (.Recipients.Count > 0) Then        'check that there is at least 1 recipient before trying to autosend
        .Send
    Else
        Err = 0
        On Error Resume Next
        .Display                    'Attempt to display the message
        If Err <> 0 Then            'if the mail cound not be displayed then display a warning and discard the message
            MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
            .Close olDiscard
            GoTo SendMessage_Done
        End If
    End If
End With
  
SendMessage = True

SendMessage_Done:
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
    Set objInsp = Nothing
    Set objWord = Nothing
    Set objdoc = Nothing
    Set objrange = Nothing
    Exit Function

HandleError:
    MsgBox Err.Number & ":" & Err.Description, vbCritical
    Resume SendMessage_Done

End Function

darbid · Nov 6, 2009

What you first need to think about is how users will choose their attachments. This function will show the windows file chooser and allow them to choose the files. Please note you must reference OFFICE 11

Code:

Private Function myFileChooser(Optional pathtofolder As String) As Variant
 
' This requires a reference to the Microsoft Office 11.0 Object Library.  YOU NEED TO ADD THIS TO YOU MDB
 
Dim fDialog As Office.FileDialog
  
 
' Set up the File dialog box.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
    ' Allow the user to make multiple selections in the dialog box.
    .AllowMultiSelect = True
    
    ' Set the title of the dialog box.
    .Title = "Select One or More Files To Be Attached to Email"
    
    ' Clear out the current filters, and then add your own.
    .filters.Clear
    .filters.Add "All Files", "*.*"
    
    'if you added an initial path then this will add this to the file dialog
    If Len(Nz(pathtofolder)) > 0 Then
        .InitialFileName = pathtofolder
    End If
    
    ' Show the dialog box. If the .Show method returns True, the
    ' user picked at least one file. If the .Show method returns
    ' False, the user clicked Cancel.
    If .Show = True Then
    
    Dim fileData
    Dim i
    ReDim fileData(.SelectedItems.Count - 1)
    'Step through each string in the FileDialogSelectedItems collection.
    For i = 1 To .SelectedItems.Count
        fileData(i - 1) = .SelectedItems(i)
    Next i
    
    myFileChooser = fileData
    
    Else
        MsgBox "You clicked Cancel in the file dialog box."
    End If
End With
 
 
End Function

When you call your function "SendMessage" for this part
"Optional varAttachmentPath As Variant" put this "myFileChooser("pathtofolder")" which will call the above
function. You need to add your choosen folder.

Then in your Sendmessage you will need to add this

Code:

Dim VarFile as varient

'this should check if they added attachments and then if they did to loop
through them and add each one to your email.

Code:

if not isempty(varAttachmentPath) then
 For Each VarFile In varAttachmentPath
        .Attachments.Add VarFile
  Next
end if

The above METHOD is the ADD method and it has other arguments which are optional
you can find these there http://msdn.microsoft.com/en-gb/library/aa220070(office.11).aspx

smbarney · Nov 6, 2009

Thanks darbid. I saw this code. However, the attachments are stored within the database--that is the pathway to the file is stored in the system, the files are stored on a network share. What I want to do is pull up a list of the attachments for a record with a checkbox by each attachment. The user checks each attachment they want to add and clicks okay to send the email.

I’ve created the unbound form that brings up the attachments. I get the email addresses by using a loop and passing them as a string to the varTo variable of the SendMessage function. Now, I need to be able to loop through the query behind the attachment subform (see the screenshot I attached), and grab the pathway to the documents checked, and attach them to the email.

Any thoughts on how I could do this? I've never seen anyone do this in the way I want--which might tell me that you can't do it. I am really stuck on this one.

Thanks again.

darbid · Nov 6, 2009

That should not be hard and I am going to let you work it out yourself.

Basically that subform is going to be based on a recordset with the important part "WHERE user clicks the box" is true. Thus you will have a recordset of only the paths of the files which the user wants.

Then you need to loop through this record set and add each file path to a variable called an array.

see the below part of the code which I showed you before. fileDate is the array. "[FONT=&quot].SelectedItems.Count" will equal the recordset.count[/FONT] and "[FONT=&quot].SelectedItems" will equal the actual path from the recordset as you loop through your record set.[/FONT]

[FONT=&quot]

Code:

Dim fileData
       Dim i

[/FONT]

Code:

  [FONT=&quot]    ReDim fileData(.SelectedItems.Count - 1)
    'Step through each string in the FileDialogSelectedItems collection.
    For i = 1 To .SelectedItems.Count
        fileData(i - 1) = .SelectedItems(i)
    Next i
    [/FONT]

you then need to pass fileDate as the variable for your attachments into your email function.

Multiple Email Attachments

smbarney

Registered User.

darbid

Registered User.

smbarney

Registered User.

Attachments

darbid

Registered User.

Similar threads

Users who are viewing this thread