| REM VBS发送邮件 - CDO.Message 邮件发送类 by yu2n [演示] |
| Sub Demo_Send_Mail() |
| |
| Dim m, sReturnValues |
| |
| |
| Set m = New CdoMail |
| |
| m.ServerName = "smtp.qq.com" |
| m.ServerPort = 25 |
| m.ServerUserName = "88888888" |
| m.ServerPassword = "Mm20130826" |
| |
| |
| 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 = 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 |
| Public Property Let ServerPort(ByVal strServerPort) sServerPort = strServerPort : End Property |
| Public Property Let ServerUserName(ByVal strUserName) sUserName = strUserName : End Property |
| Public Property Let ServerPassword(ByVal strPassword) sPassword = strPassword : End Property |
| |
| 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 |
| 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 |
| .Item(NameSpace & "smtpserver") = sServerName |
| .Item(NameSpace & "smtpserverport") = sServerPort |
| .Item(NameSpace & "smtpauthenticate") = 1 |
| .Item(NameSpace & "sendusername") = sUserName |
| .Item(NameSpace & "sendpassword") = sPassword |
| .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 |
| |
| |
| Select Case LCase( sMailType ) |
| Case "text" |
| oMail.TextBody = sMailBody |
| oMail.BodyPart.Charset = sMailPart |
| |
| Case "html" |
| sMailBody = "<meta http-equiv=""Content-Type"" content=""text/html; charset=utf-8"" /><pre>" & sMailBody & "</pre>" |
| sFileHtml = WriteText_UTF8(sMailBody) |
| oMail.CreateMHTMLBody sFileHtml |
| |
| |
| |
| |
| Case "url" |
| If fso.FileExists(sMailBody) Then sMailBody = Replace("file:///" & sMailBody, "\", "/", vbTextCompare, -1, 1) |
| oMail.CreateMHTMLBody sMailBody |
| |
| Case Else |
| oMail.BodyPart.Charset = sMailPart |
| 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 |
| |
| |
| |
| 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 |
| |
| |
| |
| 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 |
| |
| |
| 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) |
| |
| sFile = sFolder & "\" & sFileName & ".zip" |
| Call Zip(sFileSRC, sFile) |
| TmpZipFile = sFile |
| End Function |
| |
| |
| 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 |
| |
| |
| 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 |
| |
| |
| Private Function SavePfile(ByVal FileName, ByVal FileCode, ByVal TextString) |
| Dim objStream |
| Set objStream = CreateObject("ADODB.Stream") |
| With objStream |
| .Type = 2 |
| .Mode = 3 |
| .Charset = FileCode |
| .open |
| .WriteText TextString |
| .SaveToFile FileName, 2 |
| .Close |
| End With |
| Set objStream = Nothing |
| End Function |
| |
| End ClassCOPY |
发表于 2012-12-18 20:16
| 
发表于 2017-10-17 21:21
|