Help with CDO

[andrewb90]

Hello all,


I am trying to be able to send mail using CDO, and am very much over my head for my current skill level. Any help would be greatly appreciated. Here is what I have so far, but I keep getting syntax errors.

Sub emailtest()Dim CDO_Mail As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strBody As String


strSubject = "Results from Excel Spreadsheet"
strFrom = "zaxbys52401@gmail.com"
strTo = "zaxbys52401@gmail.com"
strCc = ""
strBcc = ""
strBody = "The total results for this quarter are: " & Str(Emails.Cells(2, 1))






Set CDO_Mail = CreateObject("CDO.Message")
On Error GoTo Error_Handling


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/smtpusessl") = True
    .Item("http://schemas.Microsoft.Com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.Microsoft.Com/cdo/configuration/sendusername") = "***@gmail.com"
    .Item("http://schemas.Microsoft.Com/cdo/configuration/sendpassword") = "***"
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    'Put your server name below
   .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.Gmail.Com"
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
    .Update


With CDO_Mail
    Set .Configuration = CDO_Config
End With




CDO_Mail.Subject = strSubject
CDO_Mail.From = strFrom
CDO_Mail.To = strTo
CDO_Mail.TextBody = strBody
CDO_Mail.CC = strCc
CDO_Mail.BCC = strBcc
CDO_Mail.Send


Error_Handling:
If Err.Description <> - Then MsgBox Err.Description


End Sub

 

[andrewb90]

Ok, so I changed the sending email and password for the account, and changed the port to 587, However I am still getting a runtime error. The range you have in there, is that for a pdf copy of cells or is that the email list?

 

[Kenneth Hobson]

What is the nature of the error? Do you have a worksheet named Sheet1? If it is the CDO reference error, comment out the early binding Dim for cdomsg and uncomment the late binding Dim line for cdomsg or just add the CDO reference. If it is the send line that errors, it is probably because of the gmail security but I thought that you had set that. I would recommend changing it back to high security when not running the routine. I provided a link to jump to your gmail settings to toggle that.

The range is the range of emails that you said you wanted.

The PDF attachment was not added. I suggest just trying 1 or 2 emails in your range and see if it works as is. You can then add the attachment part. You would simply call your routine that creates the PDF file before the call to the gmail function where you pass that pdf's filename. When you are ready to create one email with a unique PDF file attached for that, the code can be easily modified to do that. I just need more details.

Attaching a short obfuscated example xlsm file is the best way to get specific help.

 

[andrewb90]

So, I deleted the macro and started over, and sure enough, It seems to work. (I guess I need to do that more in the future) One step at a time it is working! So is the next step the attachment then?

 

[Kenneth Hobson]

That is easy but it depends on what range or sheet you are printing. Most would copy something like the email or associated ID to make the PDF file specific to that user. The other cells would then show other associated data.

If you can post a short example file to a shared site like dropbbox.com or write out more details, we can go from there. It is rather easy though to just move the PublishPDF line into the For each c in r loop. Likely, your c.value would be replace some trigger cell in your range to print to PDF.

 

[andrewb90]

Ok, I'll try to explain as best I can. I can send you a dropbox link later this evening if needed.
On the sheet "Employees" the K & L columns are both email addresses. On the sheet "Print" Range "D:AB" would be the individual schedule information. The Rows all matchup. So the employees on Row 6 in the "Employee" page will have the schedule that is on row 6 in the "Print" sheet. That will carry through for all 6:80 rows on both sheets. Not all rows will have information and some rows are not used at all (31,57,66).

Hopefully this all makes sense.

Thank you for all of your hard work on this!!!

 

[Kenneth Hobson]

Yes, an obfuscated simple example file is the best way for me to help the best.

 

[andrewb90]

Did that file I sent make sense?

 

[Kenneth Hobson]

Not really. I don't know what range you want made into a PDF file. I guess it would be based on the emails in B7:C25. How that could be used to find a range to include in a PDF is not clear to me. I guess if you had a table of names with emails, that could be used to determine some range to make into a PDF file but I did not see anything like that.

 

[andrewb90]

So the PDF range would be the entire sheet "Print".
The Email range is on the "Employees" sheet in Columns K&L

 

[Kenneth Hobson]

I did not check for the path in ppdf. Of course ThisWorkbook.Path may suffice. Notice that I also added a unique name for the pdf file for that week's schedule.

Sub Main()
  Dim r As Range, c As Range
  Dim sTo As String, ppdf As String, pdf As String, p As String
  
  'Path PDF
  'ppdf = ThisWorkbook.Path
  ppdf = Worksheets("Settings").Range("C3").Value2
  If Right(ppdf, 1) <> "\" Then ppdf = ppdf & "\"
  
  'PDF filename
  p = Worksheets("Print").Range("D1").Value2 & " " & _
    Replace(Worksheets("Scheduler").Range("H84").Text, "/", "-")
  pdf = ppdf & p & ".pdf"
  'Debug.Print pdf
  
  'Make PDF
  PublishToPDF pdf, Worksheets("Print")
  
  Set r = Worksheets("Employees").Range("K6:L75")
  For Each c In r
    With c
      If InStr(.Value2, "@") <> 0 Then sTo = sTo & "," & .Value2
    End With
  Next c
  
  If sTo = "" Then
    MsgBox sTo, vbCritical, "Ending Macro - Missing email(s)"
    Exit Sub
  End If
  
  sTo = Right(sTo, Len(sTo) - 1)
  
  Gmail "ken@gmail.com", "Ken", _
    p & " ken", _
    "See attached file: " & pdf, _
    sTo, _
    "1@2.3", _
    pdf
End Sub


' http://www.blueclaw-db.com/access_email_gmail.htm
' http://msdn.microsoft.com/en-us/library/ms872547%28EXCHG.65%29.aspx
' Add CDO reference for early binding method
'  Tools > References > Microsoft CDO for Windows 2000 Library
'    c:\windows\system32\cdosys.dll
' http://www.rondebruin.nl/cdo.htm  'Other cdo tips for cdo to Outlook from Excel

'CDO to gmail requires lowering your security:
'https://myaccount.google.com/security#connectedapps
'at the end set, Allow less secure apps: ON

Function Gmail(sendUsername As String, sendPassword As String, subject As String, _
  textBody As String, sendTo As String, sendFrom As String, _
  Optional sAttachment As String = "")
  
  Dim cdomsg As New CDO.Message  'early binding method
  'set cdomsg=new CDO.Message 'early binding only
  'Dim cdomsg As Object 'late binding method
  Set cdomsg = CreateObject("CDO.message")  'late binding method or early binding
 
  With cdomsg.Configuration.Fields
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 25  '25 or 587
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sendUsername
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sendPassword
    .Update
  End With
  ' build email parts
  With cdomsg
    .To = sendTo
    .From = sendFrom
    .subject = subject
    .textBody = textBody
    '.BCC
    '.CC
    '.ReplyTo = sendFrom
    '.HTMLBody
    '.HTMLBodyPart
    If Dir(sAttachment) = "" Then sAttachment = ""
    If sAttachment <> "" Then .AddAttachment (sAttachment)
    .Send
  End With
  Set cdomsg = Nothing
End Function

Function PublishToPDF(fName As String, o As Object, _
  Optional tfGetFilename As Boolean = False) As String
  Dim rc As Variant
  rc = fName
  If tfGetFilename Then
    rc = Application.GetSaveAsFilename(fName, "PDF (*.pdf), *.pdf", 1, "Publish to PDF")
    If rc = "" Then Exit Function
  End If
  
  o.ExportAsFixedFormat Type:=xlTypePDF, Filename:=rc _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
  :=False, OpenAfterPublish:=False
  
  PublishToPDF = rc
End Function