Here's an example of how you can pass a directory and attached all its files
Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
Function SendCDOMail(sTo As String, sSubject As String, sBody As String, _
Optional sBCC As Variant, Optional AttachmentPath As Variant)
' On Error GoTo Error_Handler
Dim objCDOMsg As Object
Dim i As Long
Const StrPath = "P:\aa\"
AttachmentPath = FF_ListFilesInDir(StrPath)
Set objCDOMsg = CreateObject("CDO.Message")
'CDO Configuration
With objCDOMsg.Configuration.Fields
'
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
'Server port (typically 25, 587)
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
'SMTP server IP or Name
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "YourEmailServer"
'Type of authentication, NONE, Basic (Base64 encoded), NTLM
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
'SMTP Account User ID
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "YourEMailAddress"
'SMTP Account Password
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "YourPassword"
'Use SSL for the connection (False or True) -> If using SSL, do not specify the Port above
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
'CDO Message
objCDOMsg.Subject = sSubject
objCDOMsg.From = "YourEMailAddress"
objCDOMsg.To = sTo
'objCDOMsg.TextBody = sBody 'This would be for plain text e-mails
objCDOMsg.HTMLBody = sBody 'This would be for HTML formatted e-mails using HTML tags
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
If IsArray(AttachmentPath) Then
For i = LBound(AttachmentPath) To UBound(AttachmentPath)
If AttachmentPath(i) <> "" And AttachmentPath(i) <> "False" Then
objCDOMsg.AddAttachment StrPath & "\" & AttachmentPath(i)
End If
Next i
Else
If AttachmentPath <> "" Then
objCDOMsg.AddAttachment AttachmentPath
End If
End If
End If
objCDOMsg.send
Error_Handler_Exit:
On Error Resume Next
Set objCDOMsg = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: SendCDOMail" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
'---------------------------------------------------------------------------------------
' Procedure : FF_ListFilesInDir
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Return a list of files in a given directory
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPath : Full path of folder to examine with trailing \
' sFilter : specific file extension to limmit search to, leave blank to list all files
'
' Usage:
' ~~~~~~
' FF_ListFilesInDir("C:\Users\Daniel\Documents\") 'List all the files
' FF_ListFilesInDir("C:\Users\Daniel\Documents\","xls") 'Only list Excel files
' FF_ListFilesInDir("C:\Users\Daniel\Documents\","doc") 'Only list Word files
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2012-Jul-13 Initial Release
' 2 2019-02-03 Updated copyright & function header
' Changed function name to follow naming convention
' Added \ check in sPath string
' Changed the function to return an array of the files
'---------------------------------------------------------------------------------------
Function FF_ListFilesInDir(sPath As String, Optional sFilter As String = "*") As Variant
Dim aFiles() As String
Dim sFile As String
Dim i As Long
On Error GoTo Error_Handler
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*." & sFilter)
Do While sFile <> vbNullString
If sFile <> "." And sFile <> ".." Then
ReDim Preserve aFiles(i)
aFiles(i) = sFile
i = i + 1
End If
sFile = Dir 'Loop through the next file that was found
Loop
FF_ListFilesInDir = aFiles
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: FF_ListFilesInDir" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Daniel Pineault, 2010-2019 Microsoft MVP
Professional Support: http://www.cardaconsultants.com
MS Access Tips and Code Samples: http://www.devhut.net
