'提取HTML中的IP地址字符串

nPos = InStr(objXmlHTTP.responseText, "[")

If nPos > 0 Then

GetWanIP = Mid(objXmlHTTP.responseText, nPos + 1)

nPos = InStr(GetWanIP, "]")

If nPos > 0 Then GetWanIP = Trim(Left(GetWanIP, nPos - 1))

End If

'銷毀XMLHTTP對象

Set objXmlHTTP = Nothing

End Function

'- ----------------------------------------- -

' 函數(shù)說明：將字符串轉(zhuǎn)換為數(shù)值

'- ----------------------------------------- -

Function Val(vNum)

If IsNumeric(vNum) Then

Val = CDbl(vNum)

Else

Val = 0

End If

End Function

'- ----------------------------------------- -

' 函數(shù)說明：發(fā)送郵件

' 參數(shù)說明：strEmailFrom：發(fā)信人郵箱

' strPassword：發(fā)信人郵箱密碼

' strEmailTo：收信人郵箱

' strSubject：郵件標(biāo)題

' strText：郵件內(nèi)容

'- ----------------------------------------- -

Function SendMail(strEmailFrom, strPassword, strEmailTo, strSubject, strText)

Dim i, nPos

Dim strUsername

Dim strSmtpServer

Dim objSock

Dim strEML

Const sckConnected = 7

Set objSock = CreateWinsock()

objSock.Protocol = 0

nPos = InStr(strEmailFrom, "@")

'校驗參數(shù)完整性和合法性

If nPos = 0 Or InStr(strEmailTo, "@") = 0 Or Len(strText) = 0 Or Len(strPassword) = 0 Then Exit Function

'根據(jù)郵箱名稱獲得郵箱帳號

strUsername = Trim(Left(strEmailFrom, nPos - 1))

'根據(jù)發(fā)信人郵箱獲得ESMTP服務(wù)器名稱

strSmtpServer = "smtp." & Trim(Mid(strEmailFrom, nPos + 1))

'組裝郵件

strEML = "MIME-Version: 1.0" & vbCrLf

strEML = strEML & "FROM:" & strEmailFrom & vbCrLf

strEML = strEML & "TO:" & strEmailTo & vbCrLf

strEML = strEML & "Subject:" & "=?GB2312?B?" & Base64Encode(strSubject) & "?=" & vbCrLf

strEML = strEML & "Content-Type: text/plain;" & vbCrLf

strEML = strEML & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf

strEML = strEML & Base64Encode(strText)

strEML = strEML & vbCrLf & "." & vbCrLf

'連接到郵件服務(wù)哭

objSock.Connect strSmtpServer, 25

'等待連接成功

For i = 1 To 10

If objSock.State = sckConnected Then Exit For

WScript.Sleep 200

Next

If objSock.State = sckConnected Then

'準(zhǔn)備發(fā)送郵件

SendCommand objSock, "EHLO VBSEmail"

SendCommand objSock, "AUTH LOGIN" '申請進行SMTP會話

SendCommand objSock, Base64Encode(strUsername)

SendCommand objSock, Base64Encode(strPassword)

SendCommand objSock, "MAIL FROM:" & strEmailFrom '發(fā)信人

SendCommand objSock, "RCPT TO:" & strEmailTo '收信人

SendCommand objSock, "DATA" '以下為郵件內(nèi)容

'發(fā)送郵件

SendCommand objSock, strEML

'結(jié)束郵箱發(fā)送

SendCommand objSock, "QUIT"

End If

'斷開連接

objSock.Close

WScript.Sleep 200

Set objSock = Nothing

End Function

'- ----------------------------------------- -

' 函數(shù)說明：SendMail的輔助函數(shù)

'- ----------------------------------------- -

Function SendCommand(objSock, strCommand)

Dim i

Dim strEcho

On Error Resume Next

objSock.SendData strCommand & vbCrLf

For i = 1 To 50 '等待結(jié)果

WScript.Sleep 200

If objSock.BytesReceived > 0 Then

objSock.GetData strEcho, vbString

If (Val(strEcho) > 0 And Val(strEcho) < 400) Or InStr(strEcho, "+OK") > 0 Then

SendCommand = True

End If

Exit Function

End If

Next

End Function

'- ----------------------------------------- -

' 函數(shù)說明：創(chuàng)建Winsock對象，如果失敗則下載注冊后再創(chuàng)建

'- ----------------------------------------- -

Function CreateWinsock()

Dim objWsh

Dim objXmlHTTP

Dim objAdoStream

Dim objFSO

Dim strSystemPath

'創(chuàng)建并返回Winsock對象

On Error Resume Next

Set CreateWinsock = CreateObject("MSWinsock.Winsock")

If Err.Number = 0 Then Exit Function '創(chuàng)建成功，返回Winsock對象

Err.Clear

On Error GoTo 0

'獲得Windows/System32系統(tǒng)文件夾位置

Set objFSO = CreateObject("Scripting.FileSystemObject")

strSystemPath = objFSO.GetSpecialFolder(1)

'如果系統(tǒng)文件夾中的mswinsck.ocx文件不存在，則從網(wǎng)站下載

If Not objFSO.FileExists(strSystemPath & "/mswinsck.ocx") Then

'創(chuàng)建XMLHTTP對象

Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP")

'下載MSWinsck.ocx控件

'將MSWinsck.ocx保存到系統(tǒng)文件夾

Set objAdoStream = CreateObject("Adodb.Stream")

objAdoStream.Type = 1 'adTypeBinary

objAdoStream.open

objAdoStream.Write objXmlHTTP.responseBody

objAdoStream.SaveToFile strSystemPath & "/mswinsck.ocx", 2 'adSaveCreateOverwrite

objAdoStream.Close

Set objAdoStream = Nothing

'銷毀XMLHTTP對象

Set objXmlHTTP = Nothing

End If

'注冊MSWinsck.ocx

Set objWsh = CreateObject("WScript.Shell")

objWsh.RegWrite "HKEY_CLASSES_ROOT/Licenses/2c49f800-c2dd-11cf-9ad6-0080c7e7b78d/", "mlrljgrlhltlngjlthrligklpkrhllglqlrk" '添加許可證

objWsh.Run "regsvr32 /s " & strSystemPath & "/mswinsck.ocx", 0 '注冊控件

Set objWsh = Nothing

'重新創(chuàng)建并返回Winsock對象

Set CreateWinsock = CreateObject("MSWinsock.Winsock")

End Function

'- ----------------------------------------- -

' 函數(shù)說明：BASE64編碼函數(shù)

'- ----------------------------------------- -

Function Base64Encode(strSource)

Dim objXmlDOM

Dim objXmlDocNode

Dim objAdoStream

Base64Encode = ""

If strSource = "" Or IsNull(strSource) Then Exit Function

'創(chuàng)建XML文檔對象

Set objXmlDOM = CreateObject("Microsoft.XMLDOM")

objXmlDOM.loadXML ("<?xml version='1.0' ?> <root/>")

Set objXmlDocNode = objXmlDOM.createElement("MyText")

objXmlDocNode.dataType = "bin.base64"

'將字符串轉(zhuǎn)換為字節(jié)數(shù)組

Set objAdoStream = CreateObject("ADODB.Stream")

objAdoStream.mode = 3

objAdoStream.Type = 2

objAdoStream.open

objAdoStream.Charset = "GB2312"

objAdoStream.writetext strSource

objAdoStream.position = 0

objAdoStream.Type = 1

objXmlDocNode.nodeTypedValue = objAdoStream.read() '將轉(zhuǎn)換后的字節(jié)數(shù)組讀入到XML文檔中

objAdoStream.Close

Set objAdoStream = Nothing

'獲得BASE64編碼

Base64Encode = objXmlDocNode.Text

objXmlDOM.documentElement.appendChild objXmlDocNode

Set objXmlDOM = Nothing

End Function