1
Rem Send by connecting to port 25 of the SMTP server.
Dim oMsg
Dim oConf
Dim oFields
Dim strHTML
Dim strTextDim oFsoRem CDOSYS tries to start the IIS Admin Service if it is stopped or turned off.Const cdoSendUsingPort = 2Rem Change these values to appropriate values for your environment
Const MySMTPServer = "192.168.0.1" ' Name or IP address of SMTP server
Const MyFrom = "<[email protected]>"
Const MyToList = "[email protected];"
Const MyCcList = "[email protected]"
Const MyBccList = """tomtang"" <[email protected]>"Set oMsg = CreateObject("CDO.Message")
Set oConf = CreateObject("CDO.Configuration")
Set oFields = oConf.FieldsSet oFso = CreateObject("Scripting.FileSystemObject")Rem Set the CDOSYS configuration fields to use port 25 on the SMTP server.With oFields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
Rem ToDo: Enter name or IP address of remote SMTP server.
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = MySMTPServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End WithRem Build HTML for message body.
strHTML = "<HTML>" & _
vbCrLf & "<HEAD>" & _
vbCrLf & "<BODY>" & _
vbCrLf & "<b>This is a test HTML message, please do not reply!</b><br /><br />" & _
vbCrLf & "<b>Best Regards,</b><br />" & _
vbCrLf & "<b>IT</b><br />" & _
vbCrLf & "<br /><br />" & _
vbCrLf & "</BODY>" & _
vbCrLf & "</HTML>"strText = "This is a test Text message, please do not reply!" & _
Chr(13) & "Best Regards," & _
vbCrLf & ""Rem Apply the settings to the message.
With oMsg
Set .Configuration = oConf
.From = MyFrom
.To = MyToList
.cc = MyCcList
.Bcc = MyBccList
.Subject = "Test Message"
.HTMLBody = strHTML
.TextBody = strText
.Send '发送
End WithRem Clean up variables. ‘清空
Set oMsg = Nothing
Set oConf = Nothing
Set oFso = NothingMsgBox "The email has been sent out successfully!"
' WScript.Echo "OK!"
' WScript.Quit 0 2 Dim fso ' As FileSystemObject
Dim fl ' As File
Dim fls ' As Files
Dim fd ' As Folder
Dim spath ' As String
Dim dpath ' As String
Dim i ' As Integer
Dim j ' As Integer
Dim mydb ' As ADODB.Connection
Dim myrd ' As ADODB.Recordset
Dim conn ' As String
Dim sqll ' As String
Dim toaddr ' As String
Dim ccaddr ' As String
Dim mailGroup(10) ' As String
Dim rptRootPath ' As String'On Error Resume NextSet fso = CreateObject("Scripting.FileSystemObject")
Set mydb = CreateObject("ADODB.Connection")
Set myrd = CreateObject("ADODB.recordset")
toaddr = ""
ccaddr = ""
mailGroup(1) = ""
rptRootPath = "E:\Program\AccountsReceivable\Report\Detail"conn = "server=.;UID=maz;PWD=111;Database=zuellig;"
sqll = "SELECT * FROM slst WHERE Del <> 'Y' ORDER BY slno ASC "
mydb.open conn
myrd.CursorType = adOpenKeyset
Set myrd = mydb.execute(sqll)Mailfile_AR
myrd.close
mydb.close
Set myrd = Nothing
Set mydb = Nothing
Set fso = Nothing Sub SendMail(aimto,aimcc,sstr,flatt1)
Dim mymail
Dim bodyString
Set mymail = CreateObject("CDO.Message")
bodyString = "各位同事:<br />" & chr(13)
bodyString = bodyString & "请收到信后不要回复到该邮件地址.<br />" & chr(13)
bodyString = bodyString & "如有问题请联系相关人员.<br />" & chr(13)
bodyString = bodyString & "<br />" & chr(13)
bodyString = bodyString & "Best Regards.<br />"
mymail.From = "[email protected]"
mymail.To = aimto
mymail.Cc = aimcc mymail.Subject = sstr
mymail.HTMLBody = bodyString
mymail.AddAttachment flatt1
mymail.Send
Set mymail = Nothing
End SubSub Mailfile_AR()
Dim slno ' As String
Dim mailAddr ' As String
Dim mailCc ' As String
Dim attf1 ' As String
Dim Subj ' As String
mailCc = ccaddr
' ===> \Sales\SHA <===
spath = rptRootPath & "\Sales\SHA\"
Set fd = fso.GetFolder(spath)
Set fls = fd.Files
For Each fl In fls
myrd.MoveFirst
mailAddr = ""
subj = ""
attf1 = spath + fl.Name
slno = Mid(Trim(fl.name), 1, 3)
GetFind myrd,slno
If Not myrd.eof Then
mailAddr = Trim(myrd.fields("armail").value)
If mailAddr <> "" Then
mailAddr = mailAddr & ";" & toaddr
Else
mailAddr = toaddr
End If
subj = myrd.fields("cname").value
If Len(subj) = 0 Then subj = slno
End If
If Mid(Trim(slno), 1, 1) = "1" Or Mid(Trim(slno), 1, 1) = "2" Then
SendMail mailAddr, mailGroup(1) & ";" & mailCc, "AR - " & subj, attf1
Else
SendMail mailAddr, mailCc, "AR - " & subj, attf1
End If
fl.Delete True
Next Set fls = Nothing
Set fd = Nothing
End SubSub GetFind(myrt, vps)
myrt.MoveFirst
While Not myrt.EOF
If vps = Trim(myrt.Fields("slno").Value) Then
Exit Sub
End If
myrt.MoveNext
Wend
End Sub
就是讲如何将1中的smtp移执到2中的邮件发送代码
Rem Send by connecting to port 25 of the SMTP server.
Dim oMsg
Dim oConf
Dim oFields
Dim strHTML
Dim strTextDim oFsoRem CDOSYS tries to start the IIS Admin Service if it is stopped or turned off.Const cdoSendUsingPort = 2Rem Change these values to appropriate values for your environment
Const MySMTPServer = "192.168.0.1" ' Name or IP address of SMTP server
Const MyFrom = "<[email protected]>"
Const MyToList = "[email protected];"
Const MyCcList = "[email protected]"
Const MyBccList = """tomtang"" <[email protected]>"Set oMsg = CreateObject("CDO.Message")
Set oConf = CreateObject("CDO.Configuration")
Set oFields = oConf.FieldsSet oFso = CreateObject("Scripting.FileSystemObject")Rem Set the CDOSYS configuration fields to use port 25 on the SMTP server.With oFields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
Rem ToDo: Enter name or IP address of remote SMTP server.
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = MySMTPServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End WithRem Build HTML for message body.
strHTML = "<HTML>" & _
vbCrLf & "<HEAD>" & _
vbCrLf & "<BODY>" & _
vbCrLf & "<b>This is a test HTML message, please do not reply!</b><br /><br />" & _
vbCrLf & "<b>Best Regards,</b><br />" & _
vbCrLf & "<b>IT</b><br />" & _
vbCrLf & "<br /><br />" & _
vbCrLf & "</BODY>" & _
vbCrLf & "</HTML>"strText = "This is a test Text message, please do not reply!" & _
Chr(13) & "Best Regards," & _
vbCrLf & ""Rem Apply the settings to the message.
With oMsg
Set .Configuration = oConf
.From = MyFrom
.To = MyToList
.cc = MyCcList
.Bcc = MyBccList
.Subject = "Test Message"
.HTMLBody = strHTML
.TextBody = strText
.Send '发送
End WithRem Clean up variables. ‘清空
Set oMsg = Nothing
Set oConf = Nothing
Set oFso = NothingMsgBox "The email has been sent out successfully!"
' WScript.Echo "OK!"
' WScript.Quit 0 2 Dim fso ' As FileSystemObject
Dim fl ' As File
Dim fls ' As Files
Dim fd ' As Folder
Dim spath ' As String
Dim dpath ' As String
Dim i ' As Integer
Dim j ' As Integer
Dim mydb ' As ADODB.Connection
Dim myrd ' As ADODB.Recordset
Dim conn ' As String
Dim sqll ' As String
Dim toaddr ' As String
Dim ccaddr ' As String
Dim mailGroup(10) ' As String
Dim rptRootPath ' As String'On Error Resume NextSet fso = CreateObject("Scripting.FileSystemObject")
Set mydb = CreateObject("ADODB.Connection")
Set myrd = CreateObject("ADODB.recordset")
toaddr = ""
ccaddr = ""
mailGroup(1) = ""
rptRootPath = "E:\Program\AccountsReceivable\Report\Detail"conn = "server=.;UID=maz;PWD=111;Database=zuellig;"
sqll = "SELECT * FROM slst WHERE Del <> 'Y' ORDER BY slno ASC "
mydb.open conn
myrd.CursorType = adOpenKeyset
Set myrd = mydb.execute(sqll)Mailfile_AR
myrd.close
mydb.close
Set myrd = Nothing
Set mydb = Nothing
Set fso = Nothing Sub SendMail(aimto,aimcc,sstr,flatt1)
Dim mymail
Dim bodyString
Set mymail = CreateObject("CDO.Message")
bodyString = "各位同事:<br />" & chr(13)
bodyString = bodyString & "请收到信后不要回复到该邮件地址.<br />" & chr(13)
bodyString = bodyString & "如有问题请联系相关人员.<br />" & chr(13)
bodyString = bodyString & "<br />" & chr(13)
bodyString = bodyString & "Best Regards.<br />"
mymail.From = "[email protected]"
mymail.To = aimto
mymail.Cc = aimcc mymail.Subject = sstr
mymail.HTMLBody = bodyString
mymail.AddAttachment flatt1
mymail.Send
Set mymail = Nothing
End SubSub Mailfile_AR()
Dim slno ' As String
Dim mailAddr ' As String
Dim mailCc ' As String
Dim attf1 ' As String
Dim Subj ' As String
mailCc = ccaddr
' ===> \Sales\SHA <===
spath = rptRootPath & "\Sales\SHA\"
Set fd = fso.GetFolder(spath)
Set fls = fd.Files
For Each fl In fls
myrd.MoveFirst
mailAddr = ""
subj = ""
attf1 = spath + fl.Name
slno = Mid(Trim(fl.name), 1, 3)
GetFind myrd,slno
If Not myrd.eof Then
mailAddr = Trim(myrd.fields("armail").value)
If mailAddr <> "" Then
mailAddr = mailAddr & ";" & toaddr
Else
mailAddr = toaddr
End If
subj = myrd.fields("cname").value
If Len(subj) = 0 Then subj = slno
End If
If Mid(Trim(slno), 1, 1) = "1" Or Mid(Trim(slno), 1, 1) = "2" Then
SendMail mailAddr, mailGroup(1) & ";" & mailCc, "AR - " & subj, attf1
Else
SendMail mailAddr, mailCc, "AR - " & subj, attf1
End If
fl.Delete True
Next Set fls = Nothing
Set fd = Nothing
End SubSub GetFind(myrt, vps)
myrt.MoveFirst
While Not myrt.EOF
If vps = Trim(myrt.Fields("slno").Value) Then
Exit Sub
End If
myrt.MoveNext
Wend
End Sub
就是讲如何将1中的smtp移执到2中的邮件发送代码
是需要时间的，你紧接着
Set mymail = Nothing
能行么？
'code by NetPatch
'VBS发送邮件参数说明
'You_Account：你的邮件帐号
'You_Password:你的邮件密码
'Send_Email: 主要邮件地址
'Send_Email2: 备用邮件地址
'Send_Topic: 邮件主题
'Send_Body: 邮件内容
'Send_Attachment:邮件附件
You_ID=Split(You_Account, "@", -1, vbTextCompare)
'帐号和服务器分离
MS_Space = "http://schemas.microsoft.com/CDo/configuration/"
'这个是必须要的，不过可以放心的事，不会通过微软发送邮件
Set Email = CreateObject("CDO.Message")
Email.From = You_Account
'这个一定要和发送邮件的帐号一样
Email.To = Send_Email '主要邮件地址
If Send_Email2 <> "" Then
Email.CC = Send_Email2 '备用邮件地址
End If
Email.Subject = Send_Topic '邮件主题
Email.Textbody = Send_Body '邮件内容
If Send_Attachment <> "" Then
Email.AddAttachment Send_Attachment '邮件附件
End If
With Email.Configuration.Fields
.Item(MS_Space&"sendusing") = 2 '发信端口
.Item(MS_Space&"smtpserver") = "smtp."&You_ID(1) 'SMTP服务器地址
.Item(MS_Space&"smtpserverport") = 25 'SMTP服务器端口
.Item(MS_Space&"smtpauthenticate") = 1 'cdobasec
.Item(MS_Space&"sendusername") = You_ID(0) '你的邮件帐号
.Item(MS_Space&"sendpassword") = You_Password '你的邮件密码
.Update
End With
Email.Send
'发送邮件
Set Email=Nothing
'关闭组件
Send_Mail=True
'如果没有任何错误信息，则表示发送成功,否则发送失败
If Err Then
Err.Clear
Send_Mail=False
End If
End Function
'以下是利用上面的函数发送带附件的邮件例子
If Send_Mail("[email protected]","test","[email protected]","","邮件主题","邮件内容","d:\test.exe")=True Then
Wscript.Echo "发送成功"
Else
Wscript.Echo "发送失败"
End If