VBS脚本发送邮件，密送多人，带附件，可更换账号密码代码,VBS代码库,德仔网

代码语言
代码分类
【VBS】 VBS脚本发送邮件，密送多人，带附件，可更换账号密码
作者:akang / 发布于2015/10/19/ 1127
VBS脚本发送邮件，密送多人，带附件，可更换账号密码，收信人从excel中获取

	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 & "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, strAccountName, 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("xxxxx@hust.edu.cn")
	 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, arrAccount(0), arrAccountName(0), arrPasswd(0)'这里可更换账号发送,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
试试其它关键字
同语言下
可能有用的
akang贡献的其它代码(20)