none
CDO mail error 13 - How to attach all files in a folder to an email? RRS feed

  • Question

  • Hi

    I use a code found here_ 

    ' Procedure : SendCDOMail
    ' Author    : CARDA Consultants Inc.

    It works fine. But I cant attach files. The code below give this error:

    Error 13 (Type mismatch ) in procedure SendCDOMail, line 270

        AttachmentPath = "P:\aa\*.*"
    
              'CDO Message
    120       objCDOMsg.Subject = sSubject
    130       objCDOMsg.From = "a@forssonline.com"
    140       objCDOMsg.To = sTo
              '    objCDOMsg.CC = sCC
    150       If Not IsMissing(sBCC) And IsNull(sBCC) = False Then
    160           objCDOMsg.BCC = sBCC
    170       End If
    180       objCDOMsg.TextBody = sBody
              ' Add attachments to the message.
    190       If Not IsMissing(AttachmentPath) Then
    200           If IsArray(AttachmentPath) Then
    210               For i = LBound(AttachmentPath) To UBound(AttachmentPath)
    220                   If AttachmentPath(i) <> "" And AttachmentPath(i) <> "False" Then
    230                       objCDOMsg.AddAttachment AttachmentPath(i)
    240                   End If
    250               Next i
    260           Else
    270               If AttachmentPath <> "" And AttachmentPath(i) <> "False" Then
    280                   objCDOMsg.AddAttachmentAttachmentPath
    290               End If
    300           End If
    310       End If
    320       objCDOMsg.Send




    Cheers // Peter Forss Stockholm

    Sunday, October 27, 2019 4:21 PM

Answers

  • 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

    Sunday, October 27, 2019 10:02 PM

All replies

  • Have you checked if the array AttachmentPath is populated correctly...just put a breakpoint and put a watch on it to check that it holds valid filenames
    Sunday, October 27, 2019 4:37 PM
  • Change

        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 AttachmentPath(i)
                    End If
                Next i
            Else
                If AttachmentPath <> "" And AttachmentPath(i) <> "False" Then
                    objCDOMsg.AddAttachmentAttachmentPath
                End If
            End If
        End If

    to

        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 AttachmentPath(i)
                    End If
                Next i
            Else
                If AttachmentPath <> "" Then
                    objCDOMsg.AddAttachment AttachmentPath
                End If
            End If
        End If


    Daniel Pineault, 2010-2019 Microsoft MVP
    Professional Support: http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net


    Sunday, October 27, 2019 6:10 PM
  • Also, I highly recommend you use SSL settings!


    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
     
        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 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



    Daniel Pineault, 2010-2019 Microsoft MVP
    Professional Support: http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net

    Sunday, October 27, 2019 7:20 PM
  • Hi John

    Directly after row 260 AttachmentPath is P:\aa\*.* and i is 0


    Cheers // Peter Forss Stockholm

    Sunday, October 27, 2019 7:29 PM
  • Hi Daniel

    I copy paste your code.

    Getting this error message now:


    Cheers // Peter Forss Stockholm

    Sunday, October 27, 2019 7:43 PM
  • Hi

    New code attaches one of the two files of the folder. Why not all?

    StrPath = "P:\aa\"
    '~~> *.* for all files
    strFile = Dir(StrPath & "*.*")
    AttachmentPath = StrPath & strFile
              'CDO Message
        'CDO Message
        objCDOMsg.Subject = sSubject
        objCDOMsg.From = "peter@forssonline.com"
        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 AttachmentPath(i)
                    End If
                Next i
            Else
                If AttachmentPath <> "" Then
                    objCDOMsg.AddAttachment AttachmentPath
                End If
            End If
        End If
        objCDOMsg.Send


    Cheers // Peter Forss Stockholm

    Sunday, October 27, 2019 9:28 PM
  • You can't pass a value like that.  You need to build an array of the files first and pass that.

    Daniel Pineault, 2010-2019 Microsoft MVP
    Professional Support: http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net

    Sunday, October 27, 2019 9:57 PM
  • 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

    Sunday, October 27, 2019 10:02 PM
  • Just put an Err handler to point out the erroneous entry...probably some special character fails to get recognized or you have some kind of file corruption in your directory...just copy all the files to another directory and try again...if it goes without error then go for the Err_Handler way of handling and identifying the culprit
    Sunday, October 27, 2019 10:17 PM
  • Thanks for helping Daniel

    Getting a new message now



    Cheers // Peter Forss Stockholm

    Monday, October 28, 2019 6:24 AM
  • With rows below no message:

            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
            'Server port (typically 25, 587)
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            'SMTP server IP or Name
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "****.****.se"
            '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") = "peter@*****.com"
            'SMTP Account Password
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "***"
            '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") = False
            .Update

    The code from Daniel works. All files attached!

    :-)


    Cheers // Peter Forss Stockholm



    Monday, October 28, 2019 6:44 AM