VBS发送邮件 - CDO.Message 邮件发送类 by yu2n(页 1) - VBS原创&转载 - 批处理之家 BAT,CMD,批处理,PowerShell,VBS,DOS

yu2n 发表于 2012-12-18 20:16

VBS发送邮件 - CDO.Message 邮件发送类 by yu2n

[i=s] 本帖最后由 yu2n 于 2013-9-16 22:06 编辑 [/i]

名称：VBS发送邮件 - CDO.Message 邮件发送类 by yu2n

功能：可发Text、HTML格式邮件，也可以把一个网页文件(或者一个网页的网址)作为邮件内容。

原理：使用系统自带CDO控件发送邮件，使用系统自带Zip控件压缩附件(压缩附件后能显著提高发送速度)。

测试：此脚本已通过XP(简体/繁体)、Win7测试。

提示：推荐使用QQ邮箱的SMTP服务，发送至139邮箱的手机邮箱(或者QQ邮箱的手机邮箱)。可以实现电脑自动发送，手机短信实时显示的功能。【此功能是免费的】

[color=Red]更新：2013-9-16[/color]
1. 支持附件列表中包含文件夹路径。
2. url 邮件内容类型的地址自动校正，可以直接输入本地路径、UNC路径。
[url=http://www.bathome.net/viewthread.php?tid=21049&page=1#pid137819]http://www.bathome.net/viewthread.php?tid=21049&page=1#pid137819[/url]

更新：2013-1-6[code]' ====================================================================================================
' 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 & "  測試 - 面条、麵條", "這是麵條與面条的测试<hr>我了个去啊！！！！"

' 添加附件(非必填)：参数可以是一个文件路径，或者是一个包含多个文件路径的数组
' 附件数组
' 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       '<html网页格式内容>
         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[/code]

yu2n 发表于 2012-12-18 20:24

其中Zip、UnZip、Format_Time 函数来源未知。:sleepy:

kevinll 发表于 2013-5-3 14:43

实用，学习了

yu2n 发表于 2013-8-26 14:50

[i=s] 本帖最后由 yu2n 于 2013-8-26 16:57 编辑 [/i]

更新：2013-08-26[code]REM 名称：VBS发送邮件 - CDO.Message 邮件发送类 by yu2n
REM 功能：可发Text、HTML格式邮件，也可以把一个网页文件(或者一个网页的网址)作为邮件内容。
REM 原理：使用系统自带CDO控件发送邮件，使用系统自带Zip控件压缩附件(压缩附件后能显著提高发送速度)。
REM 测试：此脚本已通过XP(简体/繁体)、Win7测试。
REM 提示：推荐使用QQ邮箱的SMTP服务，发送至139邮箱的手机邮箱(或者QQ邮箱的手机邮箱)。可以实现电脑自动发送，手机短信实时显示的功能。【此功能是免费的】
REM 发布：Yu2n 更新于 2013-08-26
Sub Demo_Send_Mail()
Dim m, sReturnValues
' 实例化一个 m 对象(*)
Set m = New CdoMail
' 服务器设置
m.ServerName = "smtp.qq.com"    ' <SMTP 服务器地址>
m.ServerPort = 25             ' <SMTP 服务器端口>
m.ServerUserName = "88888888" ' <SMTP 服务器用户名>
m.ServerPassword = "Mm20130826"  ' <SMTP 服务器用户密码>
' 邮件设置
m.MailFrom = "88888888@qq.com"                ' <寄件者>
m.MailTo = "7777777@qq.com; 999999999@qq.com" ' <收件者(多个收件者使用 ; 符号隔开)>
m.MailSubjectStr = "测试邮件 -- " & Now()    ' <邮件标题>
m.MailBodyType = "html"                      ' [邮件内容类型]
m.MailBody = "<h1>测试邮件</h1><hr/> -- 这是一封由电脑程序<b>自动发送</b>的测试邮件，<font color=""red"">请勿回复</font>。" ' <邮件内容>
m.MailAttachment = "c:\boot.ini; c:\boot.mgr; c:\NTDETECT.COM" ' [添加附件(多个附件使用; 符号隔开)]
' 发送邮件，将返回结果赋值给 sReturnValues
sReturnValues = m.MailSend ' <发送邮件，并取得结果>
Set m = Nothing
' 报告结果
If sReturnValues = True Then
      Msgbox "提示：邮件发送成功。"  '
Else
      Msgbox "提示：邮件发送失败！！！"  '
End If
End Sub
Class CdoMail
' 定义公共变量
Private fso, wso, objMsg
Private strServerName, strServerPort, strServerUsername, strServerPassword
Private strMailFrom, strMailTo, strMailCc, strMailBCc, strMailRrt
Private strMailSubjectStr, strMailBody, strMailBodyType, strMailBodyPart, arrMailAttachment
' 获取服务器设置参数：<SMTP 服务器地址> <SMTP 服务器端口> <SMTP 服务器用户名> <SMTP 服务器用户密码>
Public Property Let ServerName(ByVal sServerName) ' <SMTP 服务器地址>
      strServerName = sServerName
End Property
'Public Property Get ServerName ' 读取变量 Msgbox CdoMail.ServerName
' ServerName = strServerName
'End Property
Public Property Let ServerPort(ByVal sServerPort) ' <SMTP 服务器端口>
      strServerPort = sServerPort
End Property
Public Property Let ServerUsername(ByVal sServerUsername) ' <SMTP 服务器用户名>
      strServerUsername = sServerUsername
End Property
Public Property Let ServerPassword(ByVal sServerPassword) ' <SMTP 服务器用户密码>
      strServerPassword = sServerPassword
End Property
' 获取邮件设置参数：<寄件者> <收件者> [副本] [秘本] [发送“已阅读”邮件]
Public Property Let MailFrom(ByVal sMailFrom) ' <寄件者>
      strMailFrom = sMailFrom
End Property
Public Property Let MailTo(ByVal sMailTo) ' <收件者>
      strMailTo = sMailTo
End Property
Public Property Let MailCc(ByVal sMailCc) ' [副本]
      strMailCc = sMailCc
End Property
Public Property Let MailBCc(ByVal sMailBCc) ' [秘本]
      strMailBCc = sMailBCc
End Property
Public Property Let MailRrt(ByVal sMailRrt) ' [发送“已阅读”邮件]
      strMailRrt = sMailRrt
End Property
' 邮件主体设置
Public Property Let MailSubjectStr(ByVal sMailSubjectStr)
      strMailSubjectStr = sMailSubjectStr    ' <邮件标题>
End Property
Public Property Let MailBody(ByVal sMailBody)
      strMailBody = sMailBody       ' <邮件内容>
End Property
Public Property Let MailBodyType(ByVal sMailBodyType)
      strMailBodyType = sMailBodyType    ' [邮件类型 text/html/url]
End Property
Public Property Let MailBodyPart(ByVal strMailBodyPart)
      strMailBodyPart = strMailBodyPart ' [设定邮件内容编码]
End Property
Public Property Let MailAttachment(ByVal arrayMailAttachment)
      arrMailAttachment = arrayMailAttachment    ' [设定邮件附件]
End Property
' 类初始化
Private Sub Class_Initialize()
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set wso = CreateObject("wscript.Shell")
      Set objMsg = CreateObject("CDO.Message")
End Sub
' 发送邮件
Public Function MailSend()
      ' 网络不通则退出
      If Ping(strServerName) = False Then Exit Function
      ' 设置服务器
      Const NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
      On Error Resume Next
      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       '<STMP邮件服务器地址>
         .Item(NameSpace & "smtpserverport") = strServerPort    '<STMP邮件服务器端口>
         .Item(NameSpace & "smtpauthenticate") = 1             'Anonymous = 0, basic (clear-text) authentication = 1, NTLM = 2
         .Item(NameSpace & "sendusername") = strServerUsername '<STMP邮件服务器STMP用户名>
         .Item(NameSpace & "sendpassword") = strServerPassword '<STMP邮件服务器用户密码>
         .Update
      End With
      ' 设定邮件 <寄件者> <收件者> [副本抄送] [密件抄送] [邮件跟踪]
      objMsg.From = strMailFrom '<寄件者>
      objMsg.To = strMailTo    '<收件者>
      If Not strMailCc = "" Then objMsg.Cc = strMailCc    '[副本抄送]
      If Not strMailBcc = "" Then objMsg.Bcc = strMailBcc    '[密件抄送]
      ' 邮件跟踪，阅读后显示发送已阅读
      If Not strMailRrt = "" Then _
         objMsg.Fields("urn:schemas:mailheader:disposition-notification-to") = strMailRrt ' [邮件跟踪]
      If Not strMailRrt = "" Then _
         objMsg.Fields("urn:schemas:mailheader:return-receipt-to") = strMailRrt             ' [邮件跟踪]
      ' 邮件编码设定
      If strMailBodyPart = "" Then strMailBodyPart = "utf-8"
      ' 邮件主旨标题
      objMsg.Subject = strMailSubjectStr       '<邮件主旨标题>
      ' 邮件类型(text/html/url)、主旨标题、主体内容(text文本格式/html网页格式/url一个现存的网页文件地址)
      Select Case LCase( strMailBodyType )
         Case "text"
            objMsg.TextBody = strMailBody       '<文本格式内容>
            objMsg.BodyPart.Charset = strMailBodyPart '<邮件内容编码，默认utf-8>
         Case "html"
            strMailBody = "<meta http-equiv=""Content-Type"" content=""text/html; charset=utf-8"" /><pre>" & strMailBody & "</pre>"
            sFileHtml = WriteText_UTF8(strMailBody)
            objMsg.CreateMHTMLBody sFileHtml
            ' 以下方式容易乱码
            ' objMsg.HTMLBody = strMailBody       '<html网页格式内容>
            ' objMsg.BodyPart.Charset = strMailBodyPart '<邮件内容编码，默认utf-8>
         Case "url"
            objMsg.CreateMHTMLBody strMailBody '<网页文件地址>
         Case Else
            objMsg.BodyPart.Charset = strMailBodyPart '<邮件内容编码，默认utf-8>
            objMsg.TextBody = strMailBody       '<邮件内容，默认为文本格式内容>
      End Select
      ' 添加所有附件(多个附件使用 ; 符号隔开)
      If Not IsArray( arrMailAttachment ) Then arrMailAttachment = Split( arrMailAttachment & ";", ";")
      For i = 0 To UBound( arrMailAttachment )
         If fso.FileExists( Trim( arrMailAttachment(i) ) ) = True Then
            'objMsg.Addattachment arrMailAttachment(i)  ' 添加附件
            objMsg.Addattachment TmpZipFile( Trim( arrMailAttachment(i) ) )  ' 压缩后发送
         End If
      Next
      ' 发送
      'Delivery Status Notifications: Default = 0, Never = 1, Failure = 2, Success 4, Delay = 8, SuccessFailOrDelay = 14
      objMsg.DSNOptions = 0
      objMsg.Fields.update
      objMsg.Send
      ' 返回值
      If Err.Number = 0 Then MailSend = True :  Else :  MailSend = False :  End If
End Function
' 类注销
Private Sub class_terminate()
      Set fso = Nothing
      Set wso = Nothing
      Set objMsg = Nothing
End Sub

' ====================================================================================================

' Ping 判断网络是否联通，参数1 -主机名称或IP地址
Private Function Ping(ByVal sTarget)
      Ping = False :  If sTarget = "" Then Exit Function
      On Error Resume Next
      Const sHost = "."
      Dim PingResults, PingResult
      Set PingResults = GetObject("winmgmts:{impersonationLevel=impersonate}//" & _
            sHOST & "/root/cimv2"). ExecQuery("SELECT * FROM Win32_PingStatus " & _
               "WHERE Address = '" + sTarget + "'")
      For Each PingResult In PingResults
         If PingResult.StatusCode = 0 Then
            Ping = True : Exit For
         End If
      Next
      Set PingResults = Nothing
End Function

' 压缩文件功能，参数1 -源文件或源文件夹，参数2 -生成的Zip文件路径
Private Sub Zip(ByVal sFileSRC, ByVal myZipFile)
      Set fso = CreateObject("Scripting.FileSystemObject")
      If fso.GetExtensionName(myZipFile) <> "zip" Then
         Exit Sub
      ElseIf fso.FolderExists(sFileSRC) Then
         FType = "Folder"
      ElseIf fso.FileExists(sFileSRC) Then
         FType = "File"
         FileName = fso.GetFileName(sFileSRC)
         FolderPath = Left(sFileSRC, Len(sFileSRC) - 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(sFileSRC)
            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

' 在临时文件夹下创建 Zip 文件，并返回临时 Zip 文件路径。参数1 -待压缩的文件全路径
Private Function TmpZipFile(ByVal sFileSRC)
      Dim fso, tempFolder, tempName, tempFile
      Set fso = CreateObject("Scripting.FileSystemObject")
      If Not fso.FileExists( sFileSRC ) Then Exit Function
      ' 获取文件名(不包含拓展名)
      sFileName = fso.GetFileName( sFileSRC )
      sFileExtName = fso.GetExtensionName( sFileSRC )
      If Not sFileExtName = "" Then sFileName = Left(sFileName, Len(sFileName) - Len(sFileExtName) - 1)
      ' 创建临时文件夹
      Set tempFolder = fso.GetSpecialFolder(2)
      tempName = fso.GetTempName()  ' 取得随机临时文件名
      tempZipFolder = tempFolder & "\" & tempName
      If Not fso.FolderExists( tempZipFolder ) Then fso.CreateFolder( tempZipFolder )
      ' 创建临时 Zip 文件
      sTmpZipFile = tempZipFolder & "\" & sFileName & ".zip"
      Call Zip( sFileSRC, sTmpZipFile)
      TmpZipFile = sTmpZipFile
End Function

' 按UTF-8编码保存文本
Function WriteText_UTF8(ByVal sText)
      Dim fso, oTempFolder, sTempFolder, sTempName, sTempFile
      Set fso = CreateObject("Scripting.FileSystemObject")
      ' 创建临时文件夹
      Set oTempFolder = fso.GetSpecialFolder(2)
      sTempName = fso.GetTempName()  ' 取得随机临时文件名
      sTempFolder = oTempFolder & "\" & sTempName
      If Not fso.FolderExists( sTempFolder ) Then fso.CreateFolder( sTempFolder )
      ' 创建临时文件
      sTempFile = sTempFolder & "\CdoMail.html"
      SavePfile sTempFile, "utf-8", sText
      WriteText_UTF8 = sTempFile
End Function

'保存文件为unicode格式文本
Function SavePfile(ByVal FileName, ByVal FileCode, ByVal TextString)
      Dim objStream
      Set objStream = CreateObject("ADODB.Stream")
      With objStream
         .Type = 2
         .Mode = 3
         .Charset = FileCode    '不同编码时自己换,Chinese (Simplified) (GB2312),中文 GBK ,繁体中文 Big5 ,日文 EUC-JP ,韩文 EUC-KR,charset=UTF-8(国际化编码),ANSI,Unicode,unicode big endian
         .open
         .WriteText TextString
         .SaveToFile FileName, 2
         .Close
      End With
      Set objStream = Nothing
End Function

End Class[/code]

Spring 发表于 2013-9-5 00:15

现在还是只能加一分。。。。
这样做成一个class用起来是要方便些。最后提个建议，既然支持HTML的内容，有没有试过邮件里面带图片（不是外链哦）。
我之前也想写一个方便发邮件，最后还是发现需要的参数太多，对脚本不太了解的人还是很难使用，而对于熟悉脚本的人又没有意义，于是就没有继续了，就给你做个参考吧。

yu2n 发表于 2013-9-16 00:17

[b]回复 [url=http://bathome.net/redirect.php?goto=findpost&pid=137188&ptid=21049]5#[/url] [i]Spring[/i] [/b]

我发现CDO组件对网页所含的图片，处理是自动化的，不需要我去指定——否则工作量就要增加了。
比如，有一个网页文件 c:\ccc\cccc.htm ，其中引用了一张图片，它的源代码如下：[code]<html>
<body>
图片实例
<img src="./psu.jpg" alt="上海鲜花港 - 郁金香" />
</body>
</html>[/code]那么，发送邮件的语句为：[code]objCdo.CreateMHTMLBody "file:///c:/ccc/cccc.htm"[/code]，这可以发送成功，图片显示完整。

yu2n 发表于 2013-9-16 00:21

[i=s] 本帖最后由 yu2n 于 2013-9-16 01:12 编辑 [/i]

[quote]现在还是只能加一分。。。。
这样做成一个class用起来是要方便些。最后提个建议，既然支持HTML的内容，有没 ...
[size=2][color=#999999]Spring 发表于 2013-9-5 00:15[/color] [url=http://bathome.net/redirect.php?goto=findpost&pid=137188&ptid=21049][img]http://bathome.net/images/common/back.gif[/img][/url][/size][/quote]

更新：感谢 [url=http://bathome.net/space.php?uid=21093]Spring[/url]的反馈。[code]Case "url"
If fso.FileExists(sMailBody) Then sMailBody = Replace("file:///" & sMailBody, "\", "/", vbTextCompare, -1, 1)
oMail.CreateMHTMLBody sMailBody '<网页文件地址>[/code]2013-09-16[code]REM VBS发送邮件 - CDO.Message 邮件发送类 by yu2n [演示]
Sub Demo_Send_Mail()

Dim m, sReturnValues
' 实例化一个 m 对象(*)

Set m = New CdoMail
' 服务器设置
m.ServerName = "smtp.qq.com"    ' <SMTP 服务器地址>
m.ServerPort = 25             ' <SMTP 服务器端口>
m.ServerUserName = "88888888" ' <SMTP 服务器用户名>
m.ServerPassword = "Mm20130826"  ' <SMTP 服务器用户密码>

' 邮件设置
m.MailFrom = "88888888@qq.com"                ' <寄件者>
m.MailTo = "7777777@qq.com; 999999999@qq.com" ' <收件者(多个收件者使用 ; 符号隔开)>
m.MailSubject = "测试邮件 -- " & Now()       ' <邮件标题>
m.MailType = "html"                            ' [邮件内容类型]
m.MailBody = "<h1>测试邮件</h1><hr/> -- 这是一封由电脑程序<b>自动发送</b>的测试邮件，<font color=""red"">请勿回复</font>。" ' <邮件内容>
m.MailAttachment = "c:\boot.ini; c:\bootmgr; c:\NTDETECT.COM; d:\backup"    ' [添加附件(多个附件使用; 符号隔开)]

' 发送邮件，将返回结果赋值给 sReturnValues
sReturnValues = m.MailSend ' <发送邮件，并取得结果>
Set m = Nothing

' 报告结果
If sReturnValues = True Then
      Msgbox "提示：邮件发送成功。"  '
Else
      Msgbox "提示：邮件发送失败！！！"  '
End If

End Sub

REM 名称：VBS发送邮件 - CDO.Message 邮件发送类 by yu2n
REM 功能：可发Text、HTML格式邮件，也可以把一个网页文件(或者一个网页的网址)作为邮件内容。
REM 原理：使用系统自带CDO控件发送邮件，使用系统自带Zip控件压缩附件(压缩附件后能显著提高发送速度)。
REM 测试：此脚本已通过XP(简体/繁体)、Win7测试。
REM 提示：推荐使用QQ邮箱的SMTP服务，发送至139邮箱的手机邮箱(或者QQ邮箱的手机邮箱)。可以实现电脑自动发送，手机短信实时显示的功能。【此功能是免费的】
REM 发布：Yu2n 更新于 2013-08-26
Class CdoMail

' 定义类的成员变量
Private fso, wso, oRegEx, oMail
Private sServerName, sServerPort, sUserName, sPassword
Private sMailFrom, sMailTo, sMailCc, sMailBCc, sMailRrt
Private sMailSubject, sMailBody, sMailType, sMailPart, sMailAttachment

' 类初始化
Private Sub Class_Initialize()
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set wso = CreateObject("wscript.Shell")
      Set oMail = CreateObject("CDO.Message")
End Sub

' 类变量赋值
Public Property Let ServerName(ByVal strServerName) sServerName = strServerName :  End Property ' <SMTP 服务器地址>
Public Property Let ServerPort(ByVal strServerPort) sServerPort = strServerPort :  End Property ' <SMTP 服务器端口>
Public Property Let ServerUserName(ByVal strUserName) sUserName = strUserName :  End Property ' <SMTP 服务器用户名>
Public Property Let ServerPassword(ByVal strPassword) sPassword = strPassword :  End Property ' <SMTP 服务器用户密码>
' 获取邮件设置参数：<寄件者> <收件者> [副本] [秘本] [发送“已阅读”邮件]
Public Property Let MailFrom(ByVal strMailFrom) sMailFrom = strMailFrom :  End Property ' <寄件者>
Public Property Let MailTo(ByVal strMailTo) sMailTo = strMailTo :  End Property    ' <收件者>
Public Property Let MailCc(ByVal strMailCc) sMailCc = strMailCc :  End Property    ' [副本]
Public Property Let MailBCc(ByVal strMailBCc) sMailBCc = strMailBCc :  End Property    ' [秘本]
Public Property Let MailRrt(ByVal strMailRrt) sMailRrt = strMailRrt :  End Property    ' [发送“已阅读”邮件]
' 邮件主体设置
Public Property Let MailSubject(ByVal strMailSubject) sMailSubject = strMailSubject :  End Property    ' <邮件标题>
Public Property Let MailBody(ByVal strMailBody) sMailBody = strMailBody :  End Property    ' <邮件内容>
Public Property Let MailType(ByVal strMailType) sMailType = strMailType :  End Property    ' [邮件类型 text/html/url]
Public Property Let MailPart(ByVal strMailPart) sMailPart = strMailPart :  End Property    ' [设定邮件内容编码]
Public Property Let MailAttachment(ByVal strMailAttachment) sMailAttachment = strMailAttachment :  End Property ' [设定邮件附件]

' 类方法：发送邮件
Public Function MailSend()

      ' 网络不通则退出
      If Ping(sServerName) = False Then Exit Function

      ' 设置服务器
      Const NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
      On Error Resume Next
      With oMail.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") = sServerName       '<STMP邮件服务器地址>
         .Item(NameSpace & "smtpserverport") = sServerPort    '<STMP邮件服务器端口>
         .Item(NameSpace & "smtpauthenticate") = 1             'Anonymous = 0, basic (clear-text) authentication = 1, NTLM = 2
         .Item(NameSpace & "sendusername") = sUserName '<STMP邮件服务器STMP用户名>
         .Item(NameSpace & "sendpassword") = sPassword '<STMP邮件服务器用户密码>
         .Update
      End With

      ' 设定邮件 <寄件者> <收件者> [副本抄送] [密件抄送] [邮件跟踪]
      oMail.From  = sMailFrom '<寄件者>
      oMail.To = sMailTo    '<收件者>
      If Not sMailCc  = "" Then oMail.Cc = sMailCc    '[副本抄送]
      If Not sMailBcc = "" Then oMail.Bcc = sMailBcc    '[密件抄送]

      ' 邮件跟踪，阅读后显示发送已阅读
      If Not sMailRrt = "" Then _
         oMail.Fields("urn:schemas:mailheader:disposition-notification-to")  = sMailRrt  ' [邮件跟踪]
      If Not sMailRrt = "" Then _
         oMail.Fields("urn:schemas:mailheader:return-receipt-to")          = sMailRrt  ' [邮件跟踪]

      ' 邮件编码设定
      If sMailPart = "" Then sMailPart = "utf-8"

      ' 邮件主旨标题
      oMail.Subject = sMailSubject    '<邮件主旨标题>

      ' 邮件类型(text/html/url)、主旨标题、主体内容(text文本格式/html网页格式/url一个现存的网页文件地址)
      Select Case LCase( sMailType )
         Case "text"
            oMail.TextBody = sMailBody       '<文本格式内容>
            oMail.BodyPart.Charset = sMailPart '<邮件内容编码，默认utf-8>

         Case "html"
            sMailBody = "<meta http-equiv=""Content-Type"" content=""text/html; charset=utf-8"" /><pre>" & sMailBody & "</pre>"
            sFileHtml = WriteText_UTF8(sMailBody) ' 另存为UTF-8编码文件
            oMail.CreateMHTMLBody sFileHtml
            ' 以下方式容易乱码
            ' oMail.HTMLBody = sMailBody       '<html网页格式内容>
            ' oMail.BodyPart.Charset = sMailPart '<邮件内容编码，默认utf-8>、

         Case "url"
            If fso.FileExists(sMailBody) Then sMailBody = Replace("file:///" & sMailBody, "\", "/", vbTextCompare, -1, 1)
            oMail.CreateMHTMLBody sMailBody '<网页文件地址>

         Case Else
            oMail.BodyPart.Charset = sMailPart '<邮件内容编码，默认utf-8>
            oMail.TextBody = sMailBody       '<邮件内容，默认为文本格式内容>、

      End Select

      ' 添加所有附件(多个附件使用 ; 符号隔开)
      If Not IsArray( sMailAttachment ) Then sMailAttachment = Split( sMailAttachment & ";", ";")
      For i = 0 To UBound( sMailAttachment )
         If fso.FolderExists(Trim(sMailAttachment(i))) = True Or fso.FileExists(Trim(sMailAttachment(i))) = True Then
            oMail.Addattachment TmpZipFile(Trim(sMailAttachment(i)))  ' 将文件或文件夹压缩后发送
         End If
      Next

      ' 发送
      'Delivery Status Notifications: Default = 0, Never = 1, Failure = 2, Success 4, Delay = 8, SuccessFailOrDelay = 14
      oMail.DSNOptions = 0
      oMail.Fields.update
      oMail.Send

      ' 返回值
      If Err.Number = 0 Then MailSend = True :  Else :  MailSend = False :  End If
End Function

' 类注销
Private Sub class_terminate()
      Set fso = Nothing
      Set wso = Nothing
      Set oMail = Nothing
End Sub

' ====================================================================================================
' Ping 判断网络是否联通，参数1 -主机名称或IP地址
Private Function Ping(ByVal sTarget)
      Ping = False :  If sTarget = "" Then Exit Function
      On Error Resume Next
      Const sHost = "."
      Dim PingResults, PingResult
      Set PingResults = GetObject("winmgmts:{impersonationLevel=impersonate}//" & _
            sHOST & "/root/cimv2"). ExecQuery("SELECT * FROM Win32_PingStatus " & _
               "WHERE Address = '" + sTarget + "'")
      For Each PingResult In PingResults
         If PingResult.StatusCode = 0 Then
            Ping = True : Exit For
         End If
      Next
      Set PingResults = Nothing
End Function

' 在临时文件夹下创建 Zip 文件，并返回临时 Zip 文件路径。参数1 -待压缩的文件全路径
Private Function TmpZipFile(ByVal sFileSRC)
      Dim fso, sFileName, sFileExtName, sFile
      Set fso = CreateObject("Scripting.FileSystemObject")
      ' 取得文件名或文件夹名
      If fso.FolderExists(sFileSRC) Then
         sFileName = fso.GetFolder(sFileSRC).Name
      ElseIf fso.FileExists(sFileSRC) Then
         ' 获取文件名(不包含拓展名)
         sFileName = fso.GetFileName(sFileSRC)
         sFileExtName = fso.GetExtensionName(sFileSRC)
         ' 不处理压缩文件
         If InStr(1, "|7z|zip|rar|gz|tar|", "|" & sFileExtName & "|", vbTextCompare) > 0 Then
            TmpZipFile = sFileSRC
            Exit Function
         End If
         If Not sFileExtName = "" Then sFileName = Left(sFileName, Len(sFileName) - Len(sFileExtName) - 1)
      End If
      If sFileName = "" Then Exit Function
      ' 创建临时文件夹
      sFolder = fso.GetSpecialFolder(2) & "\" & fso.GetTempName()
      If Not fso.FolderExists(sFolder) Then fso.CreateFolder(sFolder)
      ' 创建临时 Zip 文件
      sFile = sFolder & "\" & sFileName & ".zip"
      Call Zip(sFileSRC, sFile)
      TmpZipFile = sFile
End Function

' 压缩文件功能，参数1 -源文件或源文件夹，参数2 -生成的Zip文件路径
Private Sub Zip(ByVal sFileSRC, ByVal myZipFile)
      Set fso = CreateObject("Scripting.FileSystemObject")
      If fso.GetExtensionName(myZipFile) <> "zip" Then
         Exit Sub
      ElseIf fso.FolderExists(sFileSRC) Then
         FType = "Folder"
      ElseIf fso.FileExists(sFileSRC) Then
         FType = "File"
         FileName = fso.GetFileName(sFileSRC)
         FolderPath = Left(sFileSRC, Len(sFileSRC) - 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(sFileSRC)
            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

' 按UTF-8编码保存文本
Private Function WriteText_UTF8(ByVal sText)
      Dim fso, oTempFolder, sTempFolder, sTempName, sTempFile
      Set fso = CreateObject("Scripting.FileSystemObject")
      ' 创建临时文件夹
      Set oTempFolder = fso.GetSpecialFolder(2)
      sTempName = fso.GetTempName()  ' 取得随机临时文件名
      sTempFolder = oTempFolder & "\" & sTempName
      If Not fso.FolderExists( sTempFolder ) Then fso.CreateFolder( sTempFolder )
      ' 创建临时文件
      sTempFile = sTempFolder & "\CdoMail.html"
      SavePfile sTempFile, "utf-8", sText
      WriteText_UTF8 = sTempFile
End Function

'保存文件为unicode格式文本
Private Function SavePfile(ByVal FileName, ByVal FileCode, ByVal TextString)
      Dim objStream
      Set objStream = CreateObject("ADODB.Stream")
      With objStream
         .Type = 2
         .Mode = 3
         .Charset = FileCode    '不同编码时自己换,Chinese (Simplified) (GB2312),中文 GBK ,繁体中文 Big5 ,日文 EUC-JP ,韩文 EUC-KR,charset=UTF-8(国际化编码),ANSI,Unicode,unicode big endian
         .open
         .WriteText TextString
         .SaveToFile FileName, 2
         .Close
      End With
      Set objStream = Nothing
End Function

End Class
[/code]

yu2n 发表于 2013-9-16 00:30

提供一个拖放文件即刻发送到邮箱的实例：[code]Call Send_QQ

Sub Send_QQ()

' 提取参数
Dim oArgs, arrArgs()
If WScript.Arguments.Count > 0 Then
      Set oArgs = WScript.Arguments
      ReDim Preserve arrArgs(oArgs.Count - 1)
      For i = 0 To oArgs.Count - 1
         arrArgs(i) = oArgs(i)
      Next
Else
      Msgbox "无法发送。没有附件！！"
      Exit Sub
End If

' 设定邮件内容：<邮件标题>、<邮件内容>、[添加附件(多个附件使用; 符号隔开)]
Dim sMailSubject, sMailBody, sMailAttachment
'sMailSubject = "测试邮件 -- " & Now() ' <邮件标题>
'sMailBody    = "<h1>测试邮件</h1><hr/> -- 这是一封由电脑程序<b>自动发送</b>的测试邮件，<font color=""red"">请勿回复</font>。" ' <邮件内容>
'sMailAttachment = "c:\boot.ini; c:\boot.mgr; c:\NTDETECT.COM" ' [添加附件(多个附件使用; 符号隔开)]
sMailSubject = "请查看附件 -- 含 " & (UBound(arrArgs) + 1) & " 个附件 -- " & Now()
sMailBody    = "<fieldset><legend>" & sMailSubject & "</legend>" & _
                     "<table><tr><td>" & Join(arrArgs, "</td></tr><tr><td>") & "</td></tr></table></fieldset>"
sMailAttachment = Join(arrArgs, ";")

' 配置邮箱
Dim m, sReturnValues
' 实例化一个 m 对象(*)
Set m = New CdoMail
' 服务器设置
m.ServerName       = "smtp.qq.com"    ' <SMTP 服务器地址>
m.ServerPort       = 25             ' <SMTP 服务器端口>
m.ServerUserName = "yu2n_test"          ' <SMTP 服务器用户名>
m.ServerPassword = "yu2n_test_password"  ' <SMTP 服务器用户密码>
' 邮件设置
m.MailFrom       = "yu2n_test@qq.com"    ' <寄件者>
m.MailTo          = "yu2n_test@qq.com"    ' <收件者(多个收件者使用 ; 符号隔开)>
m.MailSubject = sMailSubject    ' <邮件标题>
m.MailType    = "html"          ' [邮件内容类型]
m.MailBody       =  sMailBody       ' <邮件内容>
m.MailAttachment = sMailAttachment ' [添加附件(多个附件使用; 符号隔开)]
' 发送邮件，将返回结果赋值给 sReturnValues
sReturnValues = m.MailSend             ' <发送邮件，并取得结果>
Set m = Nothing

' 报告结果
If sReturnValues = True Then
      Msgbox "提示：邮件发送成功。"  '
Else
      Msgbox "提示：邮件发送失败！！！"  '
End If

End Sub
[/code]

tonyabbs 发表于 2017-10-17 10:22

请问CDO控件是在哪个系统文件中？我在win7 64位下用不起来。估计是精简版，有啥文件丢了。

老刘1号 发表于 2017-10-17 21:21

[b]回复 [url=http://www.bathome.net/redirect.php?goto=findpost&pid=203832&ptid=21049]9#[/url] [i]tonyabbs[/i] [/b]

[attach]10884[/attach]

yu2n 发表于 2017-10-17 22:22

[i=s] 本帖最后由 yu2n 于 2017-10-17 22:23 编辑 [/i]

[b]回复 [url=http://www.bathome.net/redirect.php?goto=findpost&pid=203832&ptid=21049]9#[/url] [i]tonyabbs[/i] [/b]

64位系统，请先执行 CommandModeX64() 函数试试。

[quote] CommandModeX64("XXXXXXXXXXXXXXX")
[url]http://www.bathome.net/thread-45852-1-1.html#pid203713[/url][/quote]

页: [1]

批处理之家's Archiver

VBS发送邮件 - CDO.Message 邮件发送类 by yu2n