VBS脚本发送邮件，密送多人，带附件，可更换账号密码，收信人从excel中获取

下面是编程之家 jb51.cc 通过网络收集整理的代码片段。

编程之家小编现在分享给大家，也给大家做个参考。

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","[email protected]"
    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 & "smtpusessl") = True
            .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
' 邮件内容设置，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 = "gb2312"   '<邮件内容编码，默认gb2312>   
                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

Function SendOneEmail(strSendAddr,strAcount,strAccountName,strPasswd)
    Set MyMail = New CdoMail
    '邮件正文内容文件读取
    TextBodyFileDir = "e:\简报邮件正文内容.txt"
    Set fso=CreateObject("Scripting.FileSystemObject")
    Set TextBodyFile=fso.OpenTextFile(TextBodyFileDir,1,False,0)
    TextBodyInfo = TextBodyFile.readall
    TextBodyFile.Close
    '设置服务器(*)：服务器地址、服务器端口、邮箱用户名、邮箱密码
    MyMail.MailServerSet    "mail.hust.edu.cn",25,strPasswd
    '设置寄件者与收件者地址(*)：寄件者、收件者、抄送副本(非必填)、密送副本(非必填)
    MyMail.MailFromTo       strAcount,"",strSendAddr
    '设置邮件内容(*)：内容类型(text/html/url)、邮件主旨标题、邮件正文文本
    MyMail.MailBody         "text","团队邮件测试",TextBodyInfo
    '添加附件(非必填)：参数可以是一个文件路径，或者是一个包含多个文件路径的数组
    MyMail.MailAttachment   Split("e:\DianNewsletter_20150916_147.pdf","|")
    ' 发送邮件(*)
    MyMail.Send
    '完成提示
    Msgbox "邮件发送完成!  ^_^"
End Function
Function SendEmailToOneSheetAddr(Sheet)
    arrAccountName = array("xxxxx")'这里三行可以设置多个账号、密码
    arrAccount = array("[email protected]")
    arrPasswd = array("xxxxxx")
    uiCntAddrMax = 2 '这里设置每封邮件发送密送人数的上限
    uiCntAddr = 0
    strSendAddr = ""
    uiRowMax = Sheet.UsedRange.Rows.Count
    uiMyEmailCnt = 0
    For uiCntRow = 2 To uiRowMax '遍历每一行
        strCurAddr = Sheet.cells(uiCntRow,3).value 'Email信息在第三列
        strSendAddr = strSendAddr & strCurAddr & ","
        uiCntAddr = uiCntAddr + 1
        If uiCntAddr = uiCntAddrMax Then
            '发送邮件
            SendOneEmail   strSendAddr,arrAccount(0),arrAccountName(0),arrPasswd(0)'这里可更换账号发送,uiMyEmailCnt
            uiMyEmailCnt = uiMyEmailCnt + 1
            If uiMyEmailCnt = 4 Then '这个uiMyEmailCnt用来记录账号个数，也就是数组中元素个数
                uiMyEmailCnt = 0
            End If
            MsgBox "邮件发送至：" & strSendAddr
            strSendAddr = ""
            uiCntAddr = 0
        End If
    Next
    
    If uiCntAddr > 0 Then
        '发送邮件
        SendOneEmail   strSendAddr,uiMyEmailCnt
        MsgBox "邮件发送至：" & strSendAddr
    End If
End Function

Function SendEmailALL(Book)
    For uiSheetCnt = 1 To 3'注意修改这里的值
        Set Sheet = Book.Sheets(uiSheetCnt)     
        SendEmailToOneSheetAddr(Sheet)
    Next
End Function

Set oExcel=CreateObject("excel.application")
Set oWorkBook=oExcel.Workbooks.Open( "e:\测试邮箱列表.xls" )
SendEmailALL(oWorkBook)
oExcel.Quit

以上是编程之家(jb51.cc)为你收集整理的全部代码内容，希望文章能够帮你解决所遇到的程序开发问题。

如果觉得编程之家网站内容还不错，欢迎将编程之家网站推荐给程序员好友。