Thread: CDO email method

Hi,

I have some code that emails a workbook that is made and saved from the main work book, however as we use FirstClass as our email client it doesn't get as far as sending the email. It opens a new email, attaches the file and puts the subject in, but it doesn't put the receipiant address in or send it.

I have been told this will work with the CDO method but I have no Idea how to work this in to my code:

Sub EMAILnSAVE()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFileName As String
    Dim cell    As Long
    Dim NR      As Long
    Dim wsData  As Worksheet
    Dim wsCSV   As Worksheet
    Dim SaveStr As String
    Dim Email_Send_To As String

'-----------------------------------------------------------------------------

    Email_Send_To = "me@myemail.ac.uk"

'-----------------------------------------------------------------------------
    
    
    On Error GoTo err_handle
    
    With Application
       .ScreenUpdating = False
       .EnableEvents = False
    End With
    
    Set Sourcewb = ActiveWorkbook
    With Sourcewb
        Set wsData = .Sheets("OUTPUT")
        Set wsCSV = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
    End With
    
    Set Destwb = Application.Workbooks.Add
        
    With Destwb.Worksheets("Sheet1")
        .Range("A1") = "EMP_ID"
        .Range("B1") = "KnownAs"
        .Range("C1") = "JobTitle"
        .Range("D1") = "LineManager"
        .Range("E1") = "ReportedSick"
        .Range("F1") = "StartDate"
        .Range("G1") = "EndDate"
        .Range("H1") = "Comments"
        .Range("A2").Name = "Area"
    End With
    
    With wsData
        NR = .Cells(.Rows.Count, "A").End(xlUp).Row
             .Range("A2:B" & NR & ",E2:E" & NR & ",G2:G" & NR & ",J2:L" & NR).Copy Destination:=Destwb.Worksheets("Sheet1").Range("Area")
    End With

   If Val(Application.Version) < 12 Then
      ' You are using Excel 97-2003.
      FileExtStr = ".xls": FileFormatNum = -4143
   Else
        Select Case Sourcewb.FileFormat
        
           ' Code 51 represents the enumeration for a macro-free
           ' Excel 2007 Workbook (.xlsx).
           Case 51
                FileExtStr = ".xlsx"
                FileFormatNum = 51
                
           ' Code 52 represents the enumeration for a
           ' macro-enabled Excel 2007 Workbook (.xlsm).
           Case 52
                 FileExtStr = ".xlsm"
                 FileFormatNum = 52
           
           ' Code 56 represents the enumeration for a
           ' a legacy Excel 97-2003 Workbook (.xls).
           Case 56
                FileExtStr = ".xls"
                FileFormatNum = 56
           ' Code 50 represents the enumeration for a
           ' binary Excel 2007 Workbook (.xlsb).
            Case Else
                FileExtStr = ".xlsb"
                FileFormatNum = 50
        End Select
   End If

    SaveStr = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
            & Application.PathSeparator _
            & ActiveSheet.Name _
            & Environ("USERNAME") _
            & " - " _
            & Format(Now, " d-m-yy h.m AM/PM")
    
    With Destwb
       .SaveAs SaveStr & FileExtStr, FileFormat:=FileFormatNum
          On Error Resume Next
       .SendMail Email_Send_To, _
          "OCP" & Format(Now, "d-m-yy")
       
          On Error GoTo err_handle
       .Close SaveChanges:=False
    End With
    
If ActiveSheet.Range("a1") = "" Then
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True

Sourcewb.Activate
    Sheets("INPUT").Select
    
Else
    Exit Sub
End If

clean_up:
    With Application
       .EnableEvents = True
       .ScreenUpdating = True
    End With
    Exit Sub

err_handle:
    MsgBox Err.Description
    Resume clean_up
End Sub

This is some code I was given for an access database we use with our email client:

Private Sub sendMail(ByVal strTo As String, strSubject As String, strBody As String, strCC As String, _
                     ByVal strUserEmail As String, ByVal strFirstClassPassword As String, _
                    Optional strAttach As String, Optional strAttach2 As String, Optional strAttach3)
On Error GoTo tagerror

' This sends the email
Dim iMsg, arrEmail
Dim errPar As String

Set iMsg = CreateObject("CDO.Message")

        iMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        iMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.0.5" 'Name or IP of remote SMTP server
        iMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25  'Server Port
        iMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUserEmail
        iMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strFirstClassPassword
        iMsg.Configuration.Fields.Update

   With iMsg
      .To = strTo
      .CC = strCC
      .From = strUserEmail
      .Subject = strSubject
      .TextBody = strBody
      .Send
   End With

    Exit Sub
tagerror:
      MsgBox "Error: (" & Err.Number & ") " & Err.DESCRIPTION & " at " & Err.Source, vbCritical
      DoCmd.SetWarnings True
    Exit Sub
    Resume
End Sub

Hi Manchester!

I've always got my queries around mailing answered by Ron De Bruin's excellent site at http://www.rondebruin.nl/cdo.htm. He IS the master!

Good luck.

Chris.

I have tried to change my code again, but I get an error 438 object support this property or method at VBAProject.

Sub EMAILnSAVE()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim cell    As Long
    Dim NR      As Long
    Dim wsData  As Worksheet
    Dim wsCSV   As Worksheet
    Dim SaveStr As String
    Dim tagerror As String
    Dim CDO_Mail_Object As Object
    Dim CDO_Config As Object
    Dim SMTP_Config As Variant
    Dim Email_Send_To, Email_Subject, Email_Body As String
    


    Set CDO_Mail_Object = CreateObject("CDO.Message")
        
        On Error GoTo tagerror

    Set CDO_Config = CreateObject("CDO.Configuration")
    CDO_Config.Load -1
    
    Set SMTP_Config = CDO_Config.Fields
        
        With SMTP_Config
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.0.5" 'Name or IP of remote SMTP server
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25  'Server Port
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUserEmail
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strFirstClassPassword
            .Update
        End With

    With CDO_Mail_Object
        Set .Configureation = CDO_Config
    End With
     
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
    
    Set Sourcewb = ActiveWorkbook
        
        With Sourcewb
            Set wsData = .Sheets("OUTPUT")
            Set wsCSV = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
        End With
    
    Set Destwb = Application.Workbooks.Add
        
        With Destwb.Worksheets("Sheet1")
            .Range("A1") = "EMP_ID"
            .Range("B1") = "KnownAs"
            .Range("C1") = "JobTitle"
            .Range("D1") = "LineManager"
            .Range("E1") = "ReportedSick"
            .Range("F1") = "StartDate"
            .Range("G1") = "EndDate"
            .Range("H1") = "Comments"
            .Range("A2").Name = "Area"
        End With
    
            With wsData
                NR = .Cells(.Rows.Count, "A").End(xlUp).Row
                    .Range("A2:B" & NR & ",E2:E" & NR & ",G2:G" & NR & ",J2:L" & NR).Copy Destination:=Destwb.Worksheets("Sheet1").Range("Area")
            End With

   If Val(Application.Version) < 12 Then
      ' You are using Excel 97-2003.
      FileExtStr = ".xls": FileFormatNum = -4143
   Else
        Select Case Sourcewb.FileFormat
        
           ' Code 51 represents the enumeration for a macro-free
           ' Excel 2007 Workbook (.xlsx).
           Case 51
                FileExtStr = ".xlsx"
                FileFormatNum = 51
                
           ' Code 52 represents the enumeration for a
           ' macro-enabled Excel 2007 Workbook (.xlsm).
           Case 52
                 FileExtStr = ".xlsm"
                 FileFormatNum = 52
           
           ' Code 56 represents the enumeration for a
           ' a legacy Excel 97-2003 Workbook (.xls).
           Case 56
                FileExtStr = ".xls"
                FileFormatNum = 56
           ' Code 50 represents the enumeration for a
           ' binary Excel 2007 Workbook (.xlsb).
            Case Else
                FileExtStr = ".xlsb"
                FileFormatNum = 50
        End Select
   End If

    SaveStr = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
            & Application.PathSeparator _
            & ActiveSheet.Name _
            & Environ("USERNAME") _
            & " - " _
            & Format(Now, " d-m-yy h.m AM/PM")
    
 '-----------------------------------------------------------------------------

    Email_Send_To = "me@myemail.ac.uk"
    Email_Subject = "OSP " & Format(Now, "mm/yyyy")
    Email_Body = "MANAGERS DETAILS - " & Sourcewb.Worksheets("INPUT").Range("MANTODAY") & vbNewLine & vbNewLine _
                 & Sourcewb.Worksheets("INPUT").Range("Emp") & " - " & Sourcewb.Worksheets("INPUT").Range("MANAME") & "   -   " & Sourcewb.Worksheets("INPUT").Range("MANJOB") & vbNewLine & vbNewLine _
                 & " DEPARTMENT - " & Sourcewb.Worksheets("INPUT").Range("MANDEPT") & "          DIVISION - " & Sourcewb.Worksheets("INPUT").Range("MANDIV") & vbNewLine _
                 & "HEAD OF DEPARTMENT - " & Sourcewb.Worksheets("INPUT").Range("HOD") & "      SITE - " & Sourcewb.Worksheets("INPUT").Range("MANSITE") & vbNewLine _
                 & "CONTACT NUMBER - " & Sourcewb.Worksheets("INPUT").Range("MANCON")

'-----------------------------------------------------------------------------
           
    Sourcewb.Select
    
    With Destwb
       .SaveAs SaveStr & FileExtStr, FileFormat:=FileFormatNum
          On Error Resume Next
          
       CDO_Mail_Object.Subject = Email_Subject
       CDO_Mail_Object.To = Email_Send_To
       CDO_Mail_Object.Body = Email_Body
       CDO_Mail_Object.AddAttachment
       CDO_Mail_Object.Send
       
       
          On Error GoTo tagerror
          
       .Close SaveChanges:=False
    End With
    
If ActiveSheet.Range("a1") = "" Then
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True

Sourcewb.Activate
    Sheets("INPUT").Select
    
Else
    Exit Sub
End If

clean_up:
    With Application
       .EnableEvents = True
       .ScreenUpdating = True
    End With
    Exit Sub
    
tagerror:
      MsgBox "Error: (" & Err.Number & ") " & Err.Description & " at " & Err.Source, vbCritical
    Exit Sub
    Resume clean_up
    
End Sub

You don't appear to have declared or initialised the strUserEmail and strFirstClassPassword variables anywhere.

Also, you must remove the

Exit Sub

line from the tag_error: section.

VBAProject doesn't appear in your code so I haven't been responding to that - I'm just pointing out any problems I can see.
If you have a default email account set up, you shouldn't need any of that config information - you just set the From email address to your email (as in Ron's sample workbook)

Edit: I just remembered you use some weird email program, so you may need the config stuff after all, in which case you would have to specify a username and password. I would test without the config stuff first though.

Pre 2007, the workbook does not have a HasVBProject property. Try declaring wb as Object instead.

Change the dim statement from As Workbook to As Object.

As a general point, you would be well advised to develop in the earliest version you have to support.