Bill Benson (vbacreations)
vbacreations at gmail.com
Wed Jun 9 22:48:05 CDT 2010
You didn't ask but... some examples with 2 web-based "no cost" SMTP servers, plus Road runner: just set up a don't-care-about-spam account and hard code the password instead of parameter, for google and yahoo. Road runner, well, of course that is a paid service. I also have code that works for a GE server but of course that smtp server will not serve the public. Sub Yahoo(FilPath as string, recipientlist as string, MyPassword as string, mailid as string, SomeMessage as string, Somesubject as string) Dim Password As String, UserName As String Dim iMsg, iConf, Flds On Error Resume Next UserName = mailid Password = MyPassword Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") Set Flds = iConf.Fields schema = "http://schemas.microsoft.com/cdo/configuration/" Flds.Item(schema & "sendusing") = 2 Flds.Item(schema & "smtpserver") = "smtp.mail.yahoo.com" Flds.Item(schema & "smtpserverport") = 465 Flds.Item(schema & "smtpauthenticate") = 1 Flds.Item(schema & "sendusername") = left(mailid,instr(mailid,"@")-1) Flds.Item(schema & "sendpassword") = Password Flds.Item(schema & "smtpusessl") = 1 Flds.Update With iMsg .To = recipientlist .From = "<" & UserName & ">" .TextBody = SomeMessage .Subject = Somesubject '.HTMLBody = Message '.Sender = "Myname" '.Organization = "Myname" '.ReplyTo = "myemail at mydomain.com" .AddAttachment FilPath End If Set .Configuration = iConf Err.Clear .send If Err.Number <> 0 Then _ 'write an error log to a text file? End With Set iMsg = Nothing Set iConf = Nothing Set Flds = Nothing End Sub 'You will have to modify this to hard code the parameters - just showing you the serverports and config settings Sub Google() Dim Password As String, UserName As String Dim iMsg, iConf, Flds On Error Resume Next UserName = InputBox("E-Mail Address to send from?", "Enter Sender's e-Mail Address", GetSetting(ThisWorkbook.Name, "UserInfo", "GmailUserName", "someone at Gmail.com")) Password = InputBox("E-Mail Password?", "Enter Password", GetSetting(ThisWorkbook.Name, "UserInfo", "GmailPassword", "MyGmailAcctPassword")) SaveSetting ThisWorkbook.Name, "UserInfo", "GmailUserName", UserName SaveSetting ThisWorkbook.Name, "UserInfo", "GmailPassword", Password Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") Set Flds = iConf.Fields ' send one copy with Google SMTP server (with autentication) schema = "http://schemas.microsoft.com/cdo/configuration/" Flds.Item(schema & "sendusing") = 2 Flds.Item(schema & "smtpserver") = "smtp.gmail.com" Flds.Item(schema & "smtpserverport") = 465 Flds.Item(schema & "smtpauthenticate") = 1 Flds.Item(schema & "sendusername") = UserName Flds.Item(schema & "sendpassword") = Password Flds.Item(schema & "smtpusessl") = 1 Flds.Update With iMsg .To = [sendto] .From = "<" & UserName & ">" .TextBody = Range("MyMessage").Cells(1) .Subject = Range("Mysubject").Cells(1) '.HTMLBody = Message '.Sender = "Myname" '.Organization = "Myname" '.ReplyTo = "myemail at mydomain.com" If [SendAttachment] = "Yes" Then Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name ThisWorkbook.SaveCopyAs Environ("Temp") & "\Test_" & ThisWorkbook.Name .AddAttachment Environ("Temp") & "\Test_" & ThisWorkbook.Name End If Set .Configuration = iConf Err.Clear .send If Err.Number <> 0 Then MsgBox "There was an error:" & Chr(13) & Chr(13) & Err.Description If [SendAttachment] = "Yes" Then Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name End If End With Set iMsg = Nothing Set iConf = Nothing Set Flds = Nothing End Sub Sub RoadRunnerSecure() Dim Password As String, UserName As String Dim iMsg, iConf, Flds On Error Resume Next UserName = InputBox("E-Mail Address to send from?", "Enter Sender's Road Runner e-Mail Address", GetSetting(ThisWorkbook.Name, "UserInfo", "RRUserName", "someone at nycap.rr.com")) SaveSetting ThisWorkbook.Name, "UserInfo", "RRSecureUserName", UserName Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") Set Flds = iConf.Fields schema = "http://schemas.microsoft.com/cdo/configuration/" Flds.Item(schema & "sendusing") = 2 'Flds.Item(schema & "smtpserverport") = 25 Flds.Item(schema & "smtpserver") = "smtp-server.nycap.rr.com" Flds.Item(schema & "smtpserverport") = 587 Flds.Item(schema & "smtpauthenticate") = 1 UserName = "wbenson1 at nycap.rr.com" UserName = "wbenson1" Password = "Trigger1" Flds.Item(schema & "sendusername") = UserName Flds.Item(schema & "sendpassword") = Password Flds.Item(schema & "smtpusessl") = 1 Flds.Update 'schema = "http://schemas.microsoft.com/cdo/configuration/" With iMsg Set .Configuration = iConf .To = [sendto] .From = "<" & UserName & ">" .TextBody = Range("MyMessage").Cells(1) .Subject = Range("Mysubject").Cells(1) '.HTMLBody = Message '.Sender = "Myname" '.Organization = "Myname" '.ReplyTo = "myemail at mydomain.com" If [SendAttachment] = "Yes" Then Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name ThisWorkbook.SaveCopyAs Environ("Temp") & "\Test_" & ThisWorkbook.Name .AddAttachment Environ("Temp") & "\Test_" & ThisWorkbook.Name End If Set .Configuration = iConf Err.Clear .send If Err.Number <> 0 Then MsgBox "There was an error:" & Chr(13) & Chr(13) & Err.Description If [SendAttachment] = "Yes" Then Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name End If End With Set iMsg = Nothing Set Flds = Nothing Set iConf = Nothing End Sub