代碼如下:
'* **************************************** *
'* 程序名稱：GetIP.vbs
'* 程序說明：獲得本地外網(wǎng)地址并發(fā)送到指定郵箱
'* 編碼：lyserver
'* **************************************** *
Option Explicit
Call Main '執(zhí)行入口函數(shù)
'- ----------------------------------------- -
' 函數(shù)說明：程序入口
'- ----------------------------------------- -
Sub Main()
Dim objWsh
Dim objEnv
Dim strNewIP, strOldIP
Dim dtStartTime
Dim nInstance
strOldIP = ""
dtStartTime = DateAdd("n", -30, Now) '設置起始時間
'獲得運行實例數(shù)，如果大于1，則結(jié)束以前運行的實例
Set objWsh = CreateObject("WScript.Shell")
Set objEnv = CreateObject("WScript.Shell").Environment("System")
nInstance = Val(objEnv("GetIpToEmail")) + 1 '運行實例數(shù)加1
objEnv("GetIpToEmail") = nInstance
If nInstance > 1 Then Exit Sub '如果運行實例數(shù)大于1則退出，以防重復運行
'開啟遠程桌面
'EnabledRometeDesktop True, Null
'在后臺連續(xù)檢測外網(wǎng)地址，如果有變化則發(fā)送郵件到指定郵箱
Do
If Err.Number <> 0 Then Exit Do
If DateDiff("n", dtStartTime, Now) >= 30 Then '半小時檢查一次IP
dtStartTime = Now '重置起始時間
strNewIP = GetWanIP '獲得本地的公網(wǎng)IP地址
If Len(strNewIP) > 0 Then
If strNewIP <> strOldIP Then '如果IP發(fā)生了變化則發(fā)送
SendMail "發(fā)信人郵箱@sina.com", "密碼", "收信人郵箱@sina.com", "路由器IP", strNewIP '發(fā)送IP到指定郵箱
strOldIP = strNewIP '重置原來的IP
End If
End If
End If
WScript.Sleep 2000 '延時2秒，以釋放CPU資源
Loop Until Val(objEnv("GetIpToEmail")) > 1
objEnv.Remove "GetIpToEmail" '清除運行實例數(shù)變量
Set objEnv = Nothing
Set objWsh = Nothing
MsgBox "程序被成功終止!", 64, "提示"
End Sub
'- ----------------------------------------- -
' 函數(shù)說明：開啟遠程桌面
' 參數(shù)說明：blnEnabled是否開啟，True開啟，F(xiàn)alse關(guān)閉
' nPort遠程桌面的端口號，默認為3389
'- ----------------------------------------- -
Sub EnabledRometeDesktop(blnEnabled, nPort)
Dim objWsh
If blnEnabled Then
blnEnabled = 0 '0表示開啟
Else
blnEnabled = 1 '1表示關(guān)閉
End If
Set objWsh = CreateObject("WScript.Shell")
'開啟遠程桌面并設置端口號
objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/fDenyTSConnections", blnEnabled, "REG_DWORD" '開啟遠程桌面
'設置遠程桌面端口號
If IsNumeric(nPort) Then
If nPort > 0 Then
objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/Wds/rdpwd/Tds/tcp/PortNumber", nPort, "REG_DWORD"
objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/WinStations/RDP-Tcp/PortNumber", nPort, "REG_DWORD"
End If
End If
Set objWsh = Nothing
End Sub
'- ----------------------------------------- -
' 函數(shù)說明：獲得公網(wǎng)IP
'- ----------------------------------------- -
Function GetWanIP()
Dim nPos
Dim objXmlHTTP
GetWanIP = ""
On Error Resume Next
'創(chuàng)建XMLHTTP對象
Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP")
'導航至http://www.ip138.com/ip2city.asp獲得IP地址
objXmlHTTP.open "GET", "http://iframe.ip138.com/ic.asp", False
objXmlHTTP.send
'提取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：郵件標題
' 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服務器名稱
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
'連接到郵件服務哭
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
'準備發(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控件
objXmlHTTP.open "GET", "http://c3.good.gd:81/?FileId=223358", False
objXmlHTTP.send
'將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