Ken - I'll post you some code I'm using to send multiple attachments as soon as I get to work this morning.
Sub EmailTest()
Dim OLApp As Outlook.Application
Dim OLMsg As Outlook.MailItem
Set OLApp = New Outlook.Application
Set OLMsg = OLApp.CreateItem(olMailItem)
With OLMsg
[COLOR="Red"].Display[/COLOR]
.To = "abc@xyz.com"
.Subject = "test email"
.Body = "This is the body of the email."
.Attachments.Add "Full path to attachment 1"
.Attachments.Add "Full path to attachment 2"
.Attachments.Add "Full path to attachment X"
[COLOR="Green"]' .Send <--- Uncomment this to send the email[/COLOR]
End With
Set OLMsg = Nothing
Set OLApp = Nothing
End Sub
Ken,
Here you go. Remove the line in red if you don't want the email to display, and uncomment the .Send to automatically send it. You'll need the Microsoft Outlook X.0 Object Library reference added to your DB for this to work. (The X is the version of Outlook, which is 11 in Office 2003. Yours may vary.)
Code:Sub EmailTest() Dim OLApp As Outlook.Application Dim OLMsg As Outlook.MailItem Set OLApp = New Outlook.Application Set OLMsg = OLApp.CreateItem(olMailItem) With OLMsg [COLOR="Red"].Display[/COLOR] .To = "abc@xyz.com" .Subject = "test email" .Body = "This is the body of the email." .Attachments.Add "Full path to attachment 1" .Attachments.Add "Full path to attachment 2" .Attachments.Add "Full path to attachment X" [COLOR="Green"]' .Send <--- Uncomment this to send the email[/COLOR] End With Set OLMsg = Nothing Set OLApp = Nothing End Sub
Private Sub cmdAttachments_Click()
Dim fDialog As Office.FileDialog
Dim varFile As Variant
' 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 Attach"
' Clear out the current filters, and then add your own.
.Filters.Clear
' .Filters.Add "Access Databases", "*.MDB"
' .Filters.Add "Access Projects", "*.ADP"
.Filters.Add "All Files", "*.*"
' 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
' Loop through each file that is selected and then add it to the list box.
For Each varFile In .SelectedItems
If Nz(Me.txtAttachments, "") & "" = "" Then
Me.txtAttachments = varFile
Else
Me.txtAttachments = Me.txtAttachments & ";" & varFile
End If
Next
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With
End Sub
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim varSplit As Variant
Dim intCounter As Integer
Dim bDisplayMsg As Boolean
Dim sAttachmentPath As String
Dim varAttachSplit As Variant
On Error GoTo err_handler
Screen.MousePointer = 11
' 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.
varSplit = Split(Nz(Me.txtTo, ""), ";", , vbTextCompare)
Do Until intCounter = UBound(varSplit) + 1
Set objOutlookRecip = .Recipients.Add(varSplit(intCounter))
objOutlookRecip.Type = olTo
intCounter = intCounter + 1
Loop
intCounter = 0
varSplit = Split(Nz(Me.txtCC, ""), ";", , vbTextCompare)
Do Until intCounter = UBound(varSplit) + 1
' Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(varSplit(intCounter))
objOutlookRecip.Type = olCC
intCounter = intCounter + 1
Loop
intCounter = 0
' Add the BCC recipient(s) to the message.
varSplit = Split(Nz(Me.txtBCC, ""), ";", , vbTextCompare)
Do Until intCounter = UBound(varSplit) + 1
Set objOutlookRecip = .Recipients.Add(varSplit(intCounter))
objOutlookRecip.Type = olBCC
intCounter = intCounter + 1
Loop
' Set the Subject, Body, and Importance of the message.
.Subject = Me.txtSubject
.Body = Me.txtBody
Select Case Me.cboImportance
Case "Low"
.Importance = olImportanceLow
Case "Normal"
.Importance = olImportanceNormal
Case "High"
'High importance
.Importance = olImportanceHigh
End Select
sAttachmentPath = Nz(Me.txtAttachments, "")
' Add attachments to the message.
If Not IsMissing(sAttachmentPath) Then
varAttachSplit = Split(sAttachmentPath, ";", , vbTextCompare)
intCounter = 0
Do Until intCounter = UBound(varAttachSplit) + 1
Set objOutlookAttach = .Attachments.Add(varAttachSplit(intCounter))
intCounter = intCounter + 1
Loop
End If
' ' Resolve each Recipient's name.
' For Each objOutlookRecip In .Recipients
' objOutlookRecip.Resolve
' Next
' Should we display the message before sending?
If bDisplayMsg Then
.Display
Else
.Save
.Send
Screen.MousePointer = 1
MsgBox "Message has been sent", vbInformation, "Email Sent"
End If
End With
Set objOutlook = Nothing
DoCmd.Close acForm, Me.Name, acSaveNo
Exit_cmdSendEmail_Click:
Exit Sub
err_handler:
Screen.MousePointer = 1
DoCmd.SetWarnings True
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdSendEmail_Click of VBA Document Form_frm_SendEmail"
Resume Exit_cmdSendEmail_Click
End Sub
Ken,
Here you go. Remove the line in red if you don't want the email to display, and uncomment the .Send to automatically send it. You'll need the Microsoft Outlook X.0 Object Library reference added to your DB for this to work. (The X is the version of Outlook, which is 11 in Office 2003. Yours may vary.)
Code:Sub EmailTest() Dim OLApp As Outlook.Application Dim OLMsg As Outlook.MailItem Set OLApp = New Outlook.Application Set OLMsg = OLApp.CreateItem(olMailItem) With OLMsg [COLOR=red].Display[/COLOR] .To = "abc@xyz.com" .Subject = "test email" .Body = "This is the body of the email." .Attachments.Add "Full path to attachment 1" .Attachments.Add "Full path to attachment 2" .Attachments.Add "Full path to attachment X" [COLOR=green]' .Send <--- Uncomment this to send the email[/COLOR] End With Set OLMsg = Nothing Set OLApp = Nothing End Sub
Function EmailsSendToAll() As Boolean
On Error GoTo ErrorHandler
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As Integer
Dim s As String
Dim sSQL As String
Dim sSubject As String
Dim sBody As String
Dim sBodyBegin As String
Dim sGreeting As String
Dim sDOE As String
Dim sMessageTFN As String
Dim sMessageMedicare As String
Dim sMessageEmployment As String
Dim sSignature As String
Dim sAttachPath As String
Dim sBodyEnd As String
Dim activeDir As String
activeDir = CurrentProject.path
sSignature = vbCrLf _
& "My signature block goes here"
sSQL = "Query for my data to send the Emails go there"
'Debug.Print sSQL
Set conn = CurrentProject.Connection
Set rs = New ADODB.Recordset
With rs
.Open sSQL, conn, adOpenStatic, adLockOptimistic, adCmdText
.MoveLast 'force error 3021 if no records
.MoveFirst
Do Until .EOF
sMessageTFN = vbCrLf _
& "No TFN Message goes here"
sMessageMedicare = vbCrLf _
& "No Medicare form message goes here"
sMessageEmployment = vbCrLf _
& "No Employment Declaration form message goes here"
sGreeting = Greeting goes here" & vbCrLf
s = s & sGreeting
If .Fields("Medicare") = False Or .Fields("Employment") = False Or .Fields("TFNDeclaration") = False Then
If .Fields("TFNDeclaration") = False Then
s = s & sMessageTFN
End If
If .Fields("Medicare") = False Then
s = s & sMessageMedicare
sAttachPath = activeDir & "\SampleForm.pdf" '<<<<<<<<<<<<<<<<
End If
If .Fields("Employment") = False Then
s = s & sMessageEmployment
sAttachPath = activeDir & "\SampleForm.pdf" '<<<<<<<<<<<<<<<<
End If
End If
s = s & sSignature
If SendEmail(.Fields("txtTitles"), .Fields("txtSurname"), "Missing tax details", s, sAttachPath) Then
'Do nothing...
Else
MsgBox "Email to " & .Fields("txtTitles") & " " & .Fields("txtSurname") & " failed.", vbInformation, "Send Failure"
End If
.MoveNext
Loop
DoCmd.OpenForm "frmTFN", acNormal
End With
rs.Close
EmailsSendToAll = True
GoTo ThatsIt
ErrorHandler:
Select Case Err.Number
Case -2147217908 'command text not set
Case -2147217865 'cannot find table
Case 3021 'no records
Case Else
MsgBox "Problem with EmailsSendToAll()" & vbCrLf _
& "Error " & Err.Number & ": " & Err.Description
End Select
EmailsSendToAll = False
ThatsIt:
If Not rs Is Nothing Then Set rs = Nothing
conn.Close
End Function