Thread: CDO email method

You just need to specify the path that you saved it as - i.e.:

SaveStr & FileExtStr

However, I don't believe you can send an open workbook via CDO, so you will need to close the saved copy before you try to send it.

This is the line that is coming up with 1004 error cannot change part of a merged cell.
I have tried changing this so it isn't part of a merged cell but it is coming up with the error still. (I.E. I unmerged the cells on the output sheet)

                    .Range("A2:B" & NR & ",E2:E" & NR & ",G2:G" & NR & ",J2:L" & NR).Copy Destination:=Destwb.Worksheets("Sheet1").Range("Area")

I have also ammend the attachment line as suggested

       CDO_Mail_Object.AddAttachment SaveStr & FileExtStr

and closed the workbook before the CDO sends the attachment

       .SaveAs SaveStr & FileExtStr, FileFormat:=FileFormatNum
       ActiveWorkbook.Close
       On Error Resume Next

That's because you have no data to copy, so the copy is including the header row, and there is a merged cell in the header.

You are trying to close the workbook again after you have already closed it - move the

.Close SaveChanges:=False

line up to replace the Activeworkbook.Close line.
You also need to specify a From address and actually send the email.

1. You haven't told it to send!
2. You still haven't specified a From address
3. You still haven't added in the username and password for the configuration as I said earlier.

Once you do that, it should be fine hopefully.

No idea - I don't know your mail program, as I've said before, and I don't use CDO.

I have tried changing the way the CDO configures and it seems to be working, the only thing is that this is to be used on many peoples computers and I want it to pull in there email address and password.

Is this possible?

Here is my working code:

Sub EMAILnSAVE()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Object
    Dim Destwb As Object
    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 Email_Send_To, Email_Send_From, Email_Subject, Email_Body As String
    Dim strUserEmail As String
    Dim strFirstClassPassword As String
    Dim errPar As String
    Dim iMsg As Object
    Dim iConfig As Object
    Dim sConfig As Variant
    
        
    strUserEmail = "me@myemail.ac.uk"
    strFirstClassPassword = "password"

    Set iMsg = CreateObject("CDO.Message")
    Set iConfig = CreateObject("CDO.Configuration")
    iConfig.Load -1
    Set sConfig = iConfig.Fields
        
        With sConfig
            .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 Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
    
    Set Sourcewb = ThisWorkbook
        
        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:H" & 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 = "andrew.mcinnes@themanchestercollege.ac.uk"
    Email_Send_From = "andrew.mcinnes@themanchestercollege.ac.uk"
    Email_Subject = "OSP " & Format(Now, "mm/yyyy")
    Email_Body = "MANAGERS DETAILS - " & Sourcewb.Worksheets("INPUT").Range("D15") & vbNewLine & vbNewLine _
                 & Sourcewb.Worksheets("INPUT").Range("C15") & " - " & Sourcewb.Worksheets("INPUT").Range("E15") & "   -   " & Sourcewb.Worksheets("INPUT").Range("F15") & vbNewLine & vbNewLine _
                 & " DEPARTMENT - " & Sourcewb.Worksheets("INPUT").Range("G15") & "          DIVISION - " & Sourcewb.Worksheets("INPUT").Range("H15") & vbNewLine _
                 & "HEAD OF DEPARTMENT - " & Sourcewb.Worksheets("INPUT").Range("I15") & "      SITE - " & Sourcewb.Worksheets("INPUT").Range("J15") & vbNewLine _
                 & "CONTACT NUMBER - " & Sourcewb.Worksheets("INPUT").Range("K15")

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

    
    With Destwb
       .SaveAs SaveStr & FileExtStr, FileFormat:=FileFormatNum
       .Close SaveChanges:=False
       On Error Resume Next
    End With
    
    With iMsg
        Set .Configuration = iConfig
    End With
    
            iMsg.To = Email_Send_To
            iMsg.From = Email_Send_From
            iMsg.Subject = Email_Subject
            iMsg.Textbody = Email_Body
            iMsg.AddAttachment SaveStr & FileExtStr
            iMsg.Send

          On Error GoTo tagerror

    
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
    Resume clean_up
    
End Sub

See this post.

HA! OK I get the message.

Thank you so much for your help! I really wouldnt have got to this point without you!

What I think I can do, as the code now bypasses the client completely, I can set up a new email address for the spreadsheet, so all the messages are sent through that email address.

As the senders details are included in the body of the email I will know where it has come from.

Thanks Again,

Andy

PS attached is a fully working example, if anyone is interested change the email details (server, from address, password etc) and it should work!