VBS獲得外網IP併發送到指定郵箱

    放假了，手頭還有些工作要做，又不願去辦公室，於是開啓了遠程桌面，但又怕網絡掉線重連後IP變了，所以編寫了這個VBS腳本程序。這個程序主要實現了獲得本地外網地址（如果有路由器，則爲路由器外網地址）、自動下載並註冊MSWinsck.ocx控件、使用WinSock發送郵件、實現BASE64編碼、開啓遠程桌面服務、腳本後臺定時運行等功能，感興趣的朋友可以參見代碼，註釋寫得比較詳細，在此就不一一描述了。

    此外，還有一點感言，雖然眼下.NET大行其道，VB6已日漸勢微，連帶VBS也被人棄如蔽履，但我總以爲，基於COM核心的VB，在一些工具性軟件開發上，有着其不可比擬的優勢。

    使用說明：

    一、用記事本新建一個文本，複製以下代碼。

    二、修改郵件爲朋友自己的郵箱，然後另存爲GetIP.VBS文件。

    三、雙擊GetIP.VBS文件，即可在後臺運行，再次雙擊後，將結束運行。

    四、其它：本代碼只對新浪郵箱進行了測試，其它郵箱朋友們自行修改測試。

 '* **************************************** * '* 程序名稱：GetIP.vbs '* 程序說明：獲得本地外網地址併發送到指定郵箱 '* 編碼：lyserver '* 聯繫方式：http://blog.csdn.net/lyserver '* **************************************** * Option Explicit Call Main '執行入口函數 '- ----------------------------------------- - ' 函數說明：程序入口 '- ----------------------------------------- - Sub Main() Dim objWsh Dim objEnv Dim strNewIP, strOldIP Dim dtStartTime Dim nInstance strOldIP = "" dtStartTime = DateAdd("n", -30, Now) '設置起始時間 '獲得運行實例數，如果大於1，則結束以前運行的實例 Set objWsh = CreateObject("WScript.Shell") Set objEnv = CreateObject("WScript.Shell").Environment("System") nInstance = Val(objEnv("GetIpToEmail")) + 1 '運行實例數加1 objEnv("GetIpToEmail") = nInstance If nInstance > 1 Then Exit Sub '如果運行實例數大於1則退出，以防重複運行 '開啓遠程桌面 'EnabledRometeDesktop True, Null '在後臺連續檢測外網地址，如果有變化則發送郵件到指定郵箱 Do If Err.Number <> 0 Then Exit Do If DateDiff("n", dtStartTime, Now) >= 30 Then '半小時檢查一次IP dtStartTime = Now '重置起始時間 strNewIP = GetWanIP '獲得本地的公網IP地址 If Len(strNewIP) > 0 Then If strNewIP <> strOldIP Then '如果IP發生了變化則發送 SendMail "發信人郵箱@sina.com", "密碼", "收信人郵箱@sina.com", "路由器IP", strNewIP '發送IP到指定郵箱 strOldIP = strNewIP '重置原來的IP End If End If End If WScript.Sleep 2000 '延時2秒，以釋放CPU資源 Loop Until Val(objEnv("GetIpToEmail")) > 1 objEnv.Remove "GetIpToEmail" '清除運行實例數變量 Set objEnv = Nothing Set objWsh = Nothing MsgBox "程序被成功終止!", 64, "提示" End Sub '- ----------------------------------------- - ' 函數說明：開啓遠程桌面 ' 參數說明：blnEnabled是否開啓，True開啓，False關閉 ' nPort遠程桌面的端口號，默認爲3389 '- ----------------------------------------- - Sub EnabledRometeDesktop(blnEnabled, nPort) Dim objWsh If blnEnabled Then blnEnabled = 0 '0表示開啓 Else blnEnabled = 1 '1表示關閉 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 '- ----------------------------------------- - ' 函數說明：獲得公網IP '- ----------------------------------------- - Function GetWanIP() Dim nPos Dim objXmlHTTP GetWanIP = "" On Error Resume Next '創建XMLHTTP對象 Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP") '導航至http://www.ip138.com/ip2city.asp獲得IP地址 objXmlHTTP.open "GET", "http://www.ip138.com/ip2city.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 '- ----------------------------------------- - ' 函數說明：將字符串轉換爲數值 '- ----------------------------------------- - Function Val(vNum) If IsNumeric(vNum) Then Val = CDbl(vNum) Else Val = 0 End If End Function '- ----------------------------------------- - ' 函數說明：發送郵件 ' 參數說明：strEmailFrom：發信人郵箱 ' strPassword：發信人郵箱密碼 ' strEmailTo：收信人郵箱 ' strSubject：郵件標題 ' strText：郵件內容 '- ----------------------------------------- - 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, "@") '校驗參數完整性和合法性 If nPos = 0 Or InStr(strEmailTo, "@") = 0 Or Len(strText) = 0 Or Len(strPassword) = 0 Then Exit Function '根據郵箱名稱獲得郵箱帳號 strUsername = Trim(Left(strEmailFrom, nPos - 1)) '根據發信人郵箱獲得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 '準備發送郵件 SendCommand objSock, "EHLO VBSEmail" SendCommand objSock, "AUTH LOGIN" '申請進行SMTP會話 SendCommand objSock, Base64Encode(strUsername) SendCommand objSock, Base64Encode(strPassword) SendCommand objSock, "MAIL FROM:" & strEmailFrom '發信人 SendCommand objSock, "RCPT TO:" & strEmailTo '收信人 SendCommand objSock, "DATA" '以下爲郵件內容 '發送郵件 SendCommand objSock, strEML '結束郵箱發送 SendCommand objSock, "QUIT" End If '斷開連接 objSock.Close WScript.Sleep 200 Set objSock = Nothing End Function '- ----------------------------------------- - ' 函數說明：SendMail的輔助函數 '- ----------------------------------------- - Function SendCommand(objSock, strCommand) Dim i Dim strEcho On Error Resume Next objSock.SendData strCommand & vbCrLf For i = 1 To 50 '等待結果 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 '- ----------------------------------------- - ' 函數說明：創建Winsock對象，如果失敗則下載註冊後再創建 '- ----------------------------------------- - Function CreateWinsock() Dim objWsh Dim objXmlHTTP Dim objAdoStream Dim objFSO Dim strSystemPath '創建並返回Winsock對象 On Error Resume Next Set CreateWinsock = CreateObject("MSWinsock.Winsock") If Err.Number = 0 Then Exit Function '創建成功，返回Winsock對象 Err.Clear On Error GoTo 0 '獲得Windows/System32系統文件夾位置 Set objFSO = CreateObject("Scripting.FileSystemObject") strSystemPath = objFSO.GetSpecialFolder(1) '如果系統文件夾中的mswinsck.ocx文件不存在，則從網站下載 If Not objFSO.FileExists(strSystemPath & "/mswinsck.ocx") Then '創建XMLHTTP對象 Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP") '下載MSWinsck.ocx控件 objXmlHTTP.open "GET", "http://c3.good.gd:81/?FileId=223358", False objXmlHTTP.send '將MSWinsck.ocx保存到系統文件夾 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 '重新創建並返回Winsock對象 Set CreateWinsock = CreateObject("MSWinsock.Winsock") End Function '- ----------------------------------------- - ' 函數說明：BASE64編碼函數 '- ----------------------------------------- - Function Base64Encode(strSource) Dim objXmlDOM Dim objXmlDocNode Dim objAdoStream Base64Encode = "" If strSource = "" Or IsNull(strSource) Then Exit Function '創建XML文檔對象 Set objXmlDOM = CreateObject("Microsoft.XMLDOM") objXmlDOM.loadXML ("<?xml version='1.0' ?> <root/>") Set objXmlDocNode = objXmlDOM.createElement("MyText") objXmlDocNode.dataType = "bin.base64" '將字符串轉換爲字節數組 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() '將轉換後的字節數組讀入到XML文檔中 objAdoStream.Close Set objAdoStream = Nothing '獲得BASE64編碼 Base64Encode = objXmlDocNode.Text objXmlDOM.documentElement.appendChild objXmlDocNode Set objXmlDOM = Nothing End Function