发送电子邮件CDO

我正在尝试使用CDO发送PDF和Excel电子表格页面。 我已经为大多数ISP，但我不能让它工作的Gmail。

我有一个帐户，它尝试一段时间，我尝试它（去图）。 我也有一个朋友，有一个Gmail帐户，我不能用它的帐户工作。

我已经为此工作了三天，我放弃了。 为了完成这个任务，我会花更多的精力。 下面是我试过的代码没有成功。

请帮忙。

Sub SEND_PDF_SHEET_WITH_CDO() On Error GoTo ErrHandler3: Dim filepath As String filepath = Environ$("temp") & "\" & ActiveWorkbook.Name & ".pdf" 'TODO:change filepath for the temp pdf file Range("A5:P31").Select Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ filepath, _ Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas _ :=False, OpenAfterPublish:=False Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") Set Flds = iConf.Fields With Flds .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtp.gmail.com .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 ' I have tried 25, 465, 587 and more .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "MyEmail" .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = MyPassword .Update End With With iMsg Set .Configuration = iConf .From = "MyEmail" & "<[e-mail]>" 'TODO:change email address here .To = "MyEmail" .Subject = "Hello" .HTMLBody = Range("A350").Value .AddAttachment (filepath) .Send End With Set iMsg = Nothing Set iConf = Nothing Kill filepath Exit Sub ErrHandler3: MsgBox "YOUR PDF E-MAIL DID NOT GO THROUGH. IT MAY BE YOU" _ & Chr$(13) _ & Chr$(13) _ & "HAVE NOT COMPLETED YOUR NON-OULOOK E-MAIL QUESTIONS" _ & Chr$(13) _ & Chr$(13) _ & "OR ENTERED THE INFORMATION INCORRECTLY." _ & Chr$(13) _ & Chr$(13) _ & "PLEASE TRY AGAIN AFTER RE-ENTERING YOUR INFORMATION." Range("B8").Select STOP_SUB = "YES" Set iMsg = Nothing Set iConf = Nothing Kill filepath Range("A1").Select End Sub 

---

 Sub SEND_EXCEL_SHEET_WITH_CDO() On Error GoTo ErrHandler2: 'Working in 97-2007 Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim TempFilePath As String Dim TempFileName As String Dim iMsg As Object Dim iConf As Object Dim Flds As Variant With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ActiveWorkbook 'Copy the ActiveSheet to a new workbook ActiveSheet.Copy Set Destwb = ActiveWorkbook With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007 'We exit the sub when your answer is NO in the security dialog that you only 'see when you copy a sheet from a xlsm file with macro's disabled. If Sourcewb.Name = .Name Then With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox "Your answer is NO in the security dialog" Exit Sub Else Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End If End With 'Save the new workbook/Mail it/Delete it TempFilePath = Environ$("temp") & "\" TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum .Close savechanges:=False End With Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") iConf.Load -1 ' CDO Source Defaults Set Flds = iConf.Fields With Flds .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Range("JA1").Value .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Range("JA2").Value .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Range("JA3").Value .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Range("JA4").Value .Update End With With iMsg Set .Configuration = iConf .To = "MyEmail" .CC = "" .BCC = "" .From = "My Name" & "<[e-mail]>" .Subject = "HELLO" .TextBody = "HELLO AGAIN" '<-- email body .AddAttachment TempFilePath & TempFileName & FileExtStr .Send End With 'Delete the file you have send Kill TempFilePath & TempFileName & FileExtStr With Application .ScreenUpdating = True .EnableEvents = True End With Exit Sub ErrHandler2: MsgBox "YOUR EXCEL E-MAIL DID NOT GO THROUGH. IT MAY BE YOU" _ & Chr$(13) _ & Chr$(13) _ & "HAVE NOT COMPLETED YOUR NON-OULOOK E-MAIL QUESTIONS" _ & Chr$(13) _ & Chr$(13) _ & "OR ENTERED THE INFORMATION INCORRECTLY." _ & Chr$(13) _ & Chr$(13) _ & "PLEASE TRY AGAIN AFTER RE-ENTERING YOUR INFORMATION." Range("B8").Select STOP_SUB = "YES" Kill TempFilePath & TempFileName With Application .ScreenUpdating = True .EnableEvents = True End With Application.DisplayAlerts = False ActiveWorkbook.Close End Sub 

Answer 1

此代码工作。 加上它显示任何错误，告诉你为什么它不工作。

 Set emailObj = CreateObject("CDO.Message") emailObj.From = "[e-mail]" emailObj.To = "[e-mail]" emailObj.Subject = "Test CDO" emailObj.TextBody = "Test CDO" emailObj.AddAttachment "C:/Users/User/Desktop/err.fff" Set emailConfig = emailObj.Configuration emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "dc" emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Ss" emailConfig.Fields.Update On Error Resume Next emailObj.Send If err.number = 0 then Msgbox "Done" Else Msgbox err.number & " " & err.description err.clear End If 

您的www.gmail.com帐户也需要设置为允许SMTP访问。

configuration信息来自Outlook Express（最后在WinXP中，在Vista中重命名为Windows Mail，并从Win7及更高版本中删除）。 这显示您的计算机上的默认configuration。

 Set emailObj = CreateObject("CDO.Message") Set emailConfig = emailObj.Configuration On Error Resume Next For Each fld in emailConfig.Fields msgbox fld.name & " = " & fld Next 

此外，Windows 2000的CDO并不总是包含在所有版本的Windows中。 请参阅http://support.microsoft.com/zh-cn/kb/171440