[原创] VBS发送邮件 - CDO.Message 邮件发送类 by yu2n

yu2n

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

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

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

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

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

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


更新：2013-1-6

' ====================================================================================================
' 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
复制代码

yu2n

回复 9# tonyabbs

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

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

老刘1号

回复 9# tonyabbs


    [attach]10884[/attach]

tonyabbs

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

yu2n

提供一个拖放文件即刻发送到邮箱的实例：

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
复制代码

yu2n

现在还是只能加一分。。。。
这样做成一个class用起来是要方便些。最后提个建议，既然支持HTML的内容，有没 ...
Spring 发表于 2013-9-5 00:15

更新：感谢 Spring的反馈。

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

2013-09-16

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
复制代码

yu2n

回复 5# Spring


我发现CDO组件对网页所含的图片，处理是自动化的，不需要我去指定——否则工作量就要增加了。
比如，有一个网页文件 c:\ccc\cccc.htm ，其中引用了一张图片，它的源代码如下：

<html>
<body>
图片实例
<img src="./psu.jpg"  alt="上海鲜花港 - 郁金香" />
</body>
</html>
复制代码

那么，发送邮件的语句为：

objCdo.CreateMHTMLBody "file:///c:/ccc/cccc.htm"
复制代码

，这可以发送成功，图片显示完整。

Spring

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

yu2n

更新：2013-08-26

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
复制代码

kevinll

实用，学习了

yu2n

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