VBS发送邮件 - CDO.Message 邮件发送-星旺坡

管理首页

名称：VBS发送邮件 - CDO.Message 邮件发送类 by yu2n 功能：可发Text、HTML格式邮件，也可以把一个网页文件(或者一个网页的网址)作为邮件内容。原理：使用系统自带CDO控件发送邮件，使用系统自带Zip控件压缩附件(压缩附件后能显著提高发送速度)。测试：此脚本已通过XP(简体/繁体)、Win7测试。提示：推荐使用QQ邮箱的SMTP服务，发送至139邮箱的手机邮箱(或者QQ邮箱的手机邮箱)。可以实现电脑自动发送，手机短信实时显示的功能。【此功能是免费的】更新：2013-9-16 1. 支持附件列表中包含文件夹路径。 2. url 邮件内容类型的地址自动校正，可以直接输入本地路径、UNC路径。 ' ==================================================================================================== ' CDO.Message 邮件发送类 by yu2n@qq.com ' 实例操作： ' 实例化一个 MyMail 对象(*) ' Set MyMail = New CdoMail ' 设置服务器(*)：服务器地址、服务器端口、邮箱用户名、邮箱密码 ' MyMail.MailServerSet "smtp.qq.com", 25, "yu2n", "Abcd1234" ' 设置寄件者与收件者地址(*)：寄件者、收件者、抄送副本(非必填)、密送副本(非必填) ' MyMail.MailFromTo "yu2n@qq.com", "13988888888@139.com", "", "" ' 设置邮件跟踪(非必填)：邮件被读取后发送回条的邮箱地址 ' MyMail.MailRrt "yu2n@qq.com" ' 设置邮件内容编码(非必填)：建议 UTF-8 ' MyMail.MailBodyPart "utf-8" ' 设置邮件内容(*)：内容类型(text/html/url)、邮件主旨标题、邮件正文文本 ' MyMail.MailBody "html", "No" & Timer & " 測試 - 面条、麵條", "這是麵條與面条的测试

我了个去啊！！！！" ' 添加附件(非必填)：参数可以是一个文件路径，或者是一个包含多个文件路径的数组 ' 附件数组 ' MyMail.MailAttachment Split("C:\boot.ini|C:\ntldr", "|") ' 使用 Zip 压缩附件 ' MyMail.MailAttachment TmpZipFile( WScript.ScriptFullName ) ' MyMail.MailAttachment TmpZipFile( "C:\ntldr" ) ' MyMail.MailAttachment TmpZipFile( "C:\boot.ini" ) ' 发送邮件(*) ' MyMail.Send ' 完成提示 ' Msgbox "Send Done !!" Class CdoMail ' 定义公共变量，类初始化 Public fso, wso, objMsg Private Sub Class_Initialize() Set fso = CreateObject("Scripting.FileSystemObject") Set wso = CreateObject("wscript.Shell") Set objMsg = CreateObject("CDO.Message") End Sub ' 设置服务器属性，4参数依次为：STMP邮件服务器地址，STMP邮件服务器端口，STMP邮件服务器STMP用户名，STMP邮件服务器用户密码 ' 例子：Set MyMail = New CdoMail : MyMail.MailServerSet "smtp.qq.com", 443, "yu2n", "P@sSW0rd" Public Sub MailServerSet( strServerName, strServerPort, strServerUsername, strServerPassword ) NameSpace = "http://schemas.microsoft.com/cdo/configuration/" With objMsg.Configuration.Fields .Item(NameSpace & "sendusing") = 2 'Pickup = 1(Send message using the local SMTP service pickup directory.), Port = 2(Send the message using the network (SMTP over the network). ) .Item(NameSpace & "smtpserver") = strServerName 'SMTP Server host name / ip address .Item(NameSpace & "smtpserverport") = strServerPort 'SMTP Server port .Item(NameSpace & "smtpauthenticate") = 1 'Anonymous = 0, basic (clear-text) authentication = 1, NTLM = 2 .Item(NameSpace & "sendusername") = strServerUsername '<发送者邮件地址> .Item(NameSpace & "sendpassword") = strServerPassword '<发送者邮件密码> .Update End With End Sub ' 设置邮件寄送者与接受者地址，4参数依次为：寄件者(不能空)、收件者(不能空)、副本抄送、密件抄送 Public Sub MailFromTo( strMailFrom, strMailTo, strMailCc, strMailBCc) objMsg.From = strMailFrom '<发送者邮件地址,与上面设置相同> objMsg.To = strMailTo '<接收者邮件地址> objMsg.Cc = strMailCc '[副本抄送] objMsg.Bcc = strMailBcc '[密件抄送] End Sub ' 邮件跟踪，阅读后显示发送已阅读 Public Function MailRrt( strMailRrt ) objMsg.Fields("urn:schemas:mailheader:disposition-notification-to") = strMailRrt ' "yu2n@qq.com" objMsg.Fields("urn:schemas:mailheader:return-receipt-to") = strMailRrt ' "yu2n@foxmail.com" End Function ' 邮件编码设定，例如：Set MyMail = New CdoMail : MyMail.MailBodyPart = "utf-8" Public Function MailBodyPart( strBodyPart ) objMsg.BodyPart.Charset = strBodyPart '<邮件内容编码，如"utf-8"> End Function ' 邮件内容设置，3参数依次是：邮件类型(text/html/url)、主旨标题、主体内容(text文本格式/html网页格式/url一个现存的网页文件地址) Public Function MailBody( strType, strMailSubjectStr, strMessage ) objMsg.Subject = strMailSubjectStr '<邮件主旨标题> Select Case LCase( strType ) Case "text" objMsg.TextBody = strMessage '<文本格式内容> Case "html" objMsg.HTMLBody = strMessage ' Case "url" objMsg.CreateMHTMLBody strMessage '<网页文件地址> Case Else objMsg.BodyPart.Charset = "utf-8" '<邮件内容编码，默认utf-8> objMsg.TextBody = strMessage '<邮件内容，默认为文本格式内容> End Select End Function ' 添加所有附件，参数为附件列表数组，单个文件可使用 arrPath = Split( strPath & "|", "|")传入路径。 Public Function MailAttachment( arrAttachment ) If Not IsArray( arrAttachment ) Then arrAttachment = Split( arrAttachment & "|", "|") For i = 0 To UBound( arrAttachment ) If fso.FileExists( arrAttachment(i) ) = True Then objMsg.Addattachment arrAttachment(i) End If Next End Function ' 发送邮件 Public Sub Send() 'Delivery Status Notifications: Default = 0, Never = 1, Failure = 2, Success 4, Delay = 8, SuccessFailOrDelay = 14 objMsg.DSNOptions = 0 objMsg.Fields.update objMsg.Send End Sub End Class ' ==================================================================================================== ' Ping 判断网络是否联通 Function Ping(host) On Error Resume Next Ping = False : If host = "" Then Exit Function Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery( _ "select * from Win32_PingStatus where address = '" & host & "'") For Each objStatus in objPing If objStatus.ResponseTime >= 0 Then Ping = True : Exit For Next Set objPing = nothing End Function ' ==================================================================================================== ' 压缩与解压缩文件 ' 压缩文件功能，2参数依次为：源文件或源文件夹、生成的Zip文件路径 Sub Zip(ByVal mySourceDir, ByVal myZipFile) Set fso = CreateObject("Scripting.FileSystemObject") If fso.GetExtensionName(myZipFile) <> "zip" Then Exit Sub ElseIf fso.FolderExists(mySourceDir) Then FType = "Folder" ElseIf fso.FileExists(mySourceDir) Then FType = "File" FileName = fso.GetFileName(mySourceDir) FolderPath = Left(mySourceDir, Len(mySourceDir) - Len(FileName)) Else Exit Sub End If Set f = fso.CreateTextFile(myZipFile, True) f.Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0)) f.Close Set objShell = CreateObject("Shell.Application") Select Case Ftype Case "Folder" Set objSource = objShell.NameSpace(mySourceDir) Set objFolderItem = objSource.Items() Case "File" Set objSource = objShell.NameSpace(FolderPath) Set objFolderItem = objSource.ParseName(FileName) End Select Set objTarget = objShell.NameSpace(myZipFile) intOptions = 256 objTarget.CopyHere objFolderItem, intOptions Do WScript.Sleep 1000 Loop Until objTarget.Items.Count > 0 End Sub ' ---------------------------------------------------------------------------------------------------- ' 解压文件功能，2参数依次为：源Zip文件路径、保存解压文件的路径 Sub UnZip(ByVal myZipFile, ByVal myTargetDir) Set fso = CreateObject("Scripting.FileSystemObject") If NOT fso.FileExists(myZipFile) Then Exit Sub ElseIf fso.GetExtensionName(myZipFile) <> "zip" Then Exit Sub ElseIf NOT fso.FolderExists(myTargetDir) Then fso.CreateFolder(myTargetDir) End If Set objShell = CreateObject("Shell.Application") Set objSource = objShell.NameSpace(myZipFile) Set objFolderItem = objSource.Items() Set objTarget = objShell.NameSpace(myTargetDir) intOptions = 256 objTarget.CopyHere objFolderItem, intOptions End Sub ' ---------------------------------------------------------------------------------------------------- ' 取得文件路径的文件名，2参数依次为：路径、截取的字符(如.exe) Function basename(path, suffix) Dim regex, b Set regex = New RegExp regex.Pattern = "^.*[/\\]" regex.Global = True b = regex.Replace(path, "") If VarType(suffix) = vbString And _ Right(path, Len(suffix)) = suffix Then b = Left(b, Len(b) - Len(suffix)) End If basename = b End Function ' ---------------------------------------------------------------------------------------------------- ' 在临时文件夹下创建 Zip 文件，并返回临时 Zip 文件路径 Function TmpZipFile(ByVal mySourceDir) Dim fso, tempFolder, tempName, tempFile Set fso = CreateObject("Scripting.FileSystemObject") Set tempFolder = fso.GetSpecialFolder(2) ' 设置临时文件名 tempName = fso.GetTempName() ' 创建临时 Zip 文件夹 If fso.FileExists( mySourceDir ) Then If InStrRev(mySourceDir, ".") > InStrRev(mySourceDir, "\") Then strZipFxName = Right(mySourceDir, Len(mySourceDir) -InStrRev(mySourceDir,".") +1) End If End If tempZipFolder = tempFolder & "\" & tempName If Not fso.FolderExists( tempZipFolder ) Then fso.CreateFolder( tempZipFolder ) ' 创建临时 Zip 文件 tempZipFile = tempZipFolder & "\" & basename(mySourceDir, strZipFxName) & ".zip" Call Zip( mySourceDir, tempZipFile) TmpZipFile = tempZipFile End Function ' ==================================================================================================== ' 获取当前的日期时间，并格式化 Function NowDateTime() 'MyWeek = "周" & Right(WeekdayName(Weekday(Date())), 1) & " " MyWeek = "" NowDateTime = MyWeek & Format_Time(Now(),2) & " " & Format_Time(Now(),3) End Function ' ---------------------------------------------------------------------------------------------------- Function Format_Time(s_Time, n_Flag) Dim y, m, d, h, mi, s Format_Time = "" If IsDate(s_Time) = False Then Exit Function y = cstr(year(s_Time)) m = cstr(month(s_Time)) If len(m) = 1 Then m = "0" & m d = cstr(day(s_Time)) If len(d) = 1 Then d = "0" & d h = cstr(hour(s_Time)) If len(h) = 1 Then h = "0" & h mi = cstr(minute(s_Time)) If len(mi) = 1 Then mi = "0" & mi s = cstr(second(s_Time)) If len(s) = 1 Then s = "0" & s Select Case n_Flag Case 1 Format_Time = y & m & d & h & mi & s ' yyyy-mm-dd hh:mm:ss Case 2 Format_Time = y & "-" & m & "-" & d ' yyyy-mm-dd Case 3 Format_Time = h & ":" & mi & ":" & s ' hh:mm:ss Case 4 Format_Time = y & "年" & m & "月" & d & "日" ' yyyy年mm月dd日 Case 5 Format_Time = y & m & d ' yyyymmdd End Select End Function