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