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

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

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

    使用說明：

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

    二、修改郵件為朋友自己的郵箱，然後另存新檔GetIP.VBS檔案。

    三、雙擊GetIP.VBS檔案，即可在後台運行，再次雙擊後，將結束運行。

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

 '* **************************************** *<br />'* 程式名稱：GetIP.vbs<br />'* 程式說明：獲得本地外網地址並發送到指定郵箱<br />'* 編碼：lyserver<br />'* 連絡方式：http://blog.csdn.net/lyserver<br />'* **************************************** *</p><p>Option Explicit</p><p>Call Main '執行入口函數</p><p>'- ----------------------------------------- -<br />' 函數說明：程式入口<br />'- ----------------------------------------- -<br />Sub Main()<br /> Dim objWsh<br /> Dim objEnv<br /> Dim strNewIP, strOldIP<br /> Dim dtStartTime<br /> Dim nInstance</p><p> strOldIP = ""<br /> dtStartTime = DateAdd("n", -30, Now) '設定起始時間</p><p> '獲得運行執行個體數，如果大於1，則結束以前啟動並執行執行個體<br /> Set objWsh = CreateObject("WScript.Shell")<br /> Set objEnv = CreateObject("WScript.Shell").Environment("System")<br /> nInstance = Val(objEnv("GetIpToEmail")) + 1 '運行執行個體數加1<br /> objEnv("GetIpToEmail") = nInstance<br /> If nInstance > 1 Then Exit Sub '如果運行執行個體數大於1則退出，以防重複運行</p><p> '開啟遠端桌面<br /> 'EnabledRometeDesktop True, Null</p><p> '在後台連續檢測外網地址，如果有變化則發送郵件到指定郵箱<br /> Do<br /> If Err.Number <> 0 Then Exit Do<br /> If DateDiff("n", dtStartTime, Now) >= 30 Then '半小時檢查一次IP<br /> dtStartTime = Now '重設起始時間<br /> strNewIP = GetWanIP '獲得本地的公網IP地址<br /> If Len(strNewIP) > 0 Then<br /> If strNewIP <> strOldIP Then '如果IP發生了變化則發送<br /> SendMail "發信人郵箱@sina.com", "密碼", "收信人郵箱@sina.com", "路由器IP", strNewIP '發送IP到指定郵箱<br /> strOldIP = strNewIP '重設原來的IP<br /> End If<br /> End If<br /> End If<br /> WScript.Sleep 2000 '延時2秒，以釋放CPU資源<br /> Loop Until Val(objEnv("GetIpToEmail")) > 1<br /> objEnv.Remove "GetIpToEmail" '清除運行執行個體數變數<br /> Set objEnv = Nothing<br /> Set objWsh = Nothing</p><p> MsgBox "程式被成功終止!", 64, "提示"<br />End Sub</p><p>'- ----------------------------------------- -<br />' 函數說明：開啟遠端桌面<br />' 參數說明：blnEnabled是否開啟，True開啟，False關閉<br />' nPort遠端桌面的連接埠號碼，預設為3389<br />'- ----------------------------------------- -<br />Sub EnabledRometeDesktop(blnEnabled, nPort)<br /> Dim objWsh</p><p> If blnEnabled Then<br /> blnEnabled = 0 '0表示開啟<br /> Else<br /> blnEnabled = 1 '1表示關閉<br /> End If</p><p> Set objWsh = CreateObject("WScript.Shell")<br /> '開啟遠端桌面並設定連接埠號碼<br /> objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/fDenyTSConnections", blnEnabled, "REG_DWORD" '開啟遠端桌面<br /> '設定遠端桌面連接埠號碼<br /> If IsNumeric(nPort) Then<br /> If nPort > 0 Then<br /> objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/Wds/rdpwd/Tds/tcp/PortNumber", nPort, "REG_DWORD"<br /> objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/WinStations/RDP-Tcp/PortNumber", nPort, "REG_DWORD"<br /> End If<br /> End If<br /> Set objWsh = Nothing<br />End Sub</p><p>'- ----------------------------------------- -<br />' 函數說明：獲得公網IP<br />'- ----------------------------------------- -<br />Function GetWanIP()<br /> Dim nPos<br /> Dim objXmlHTTP</p><p> GetWanIP = ""<br /> On Error Resume Next<br /> '建立XMLHTTP對象<br /> Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP")</p><p> '導航至http://www.ip138.com/ip2city.asp獲得IP地址<br /> objXmlHTTP.open "GET", "http://www.ip138.com/ip2city.asp", False<br /> objXmlHTTP.send</p><p> '提取HTML中的IP地址字串<br /> nPos = InStr(objXmlHTTP.responseText, "[")<br /> If nPos > 0 Then<br /> GetWanIP = Mid(objXmlHTTP.responseText, nPos + 1)<br /> nPos = InStr(GetWanIP, "]")<br /> If nPos > 0 Then GetWanIP = Trim(Left(GetWanIP, nPos - 1))<br /> End If</p><p> '銷毀XMLHTTP對象<br /> Set objXmlHTTP = Nothing<br />End Function</p><p>'- ----------------------------------------- -<br />' 函數說明：將字串轉換為數值<br />'- ----------------------------------------- -<br />Function Val(vNum)<br /> If IsNumeric(vNum) Then<br /> Val = CDbl(vNum)<br /> Else<br /> Val = 0<br /> End If<br />End Function</p><p>'- ----------------------------------------- -<br />' 函數說明：發送郵件<br />' 參數說明：strEmailFrom：發信人郵箱<br />' strPassword：發信人郵箱密碼<br />' strEmailTo：收信人郵箱<br />' strSubject：郵件標題<br />' strText：郵件內容<br />'- ----------------------------------------- -<br />Function SendMail(strEmailFrom, strPassword, strEmailTo, strSubject, strText)<br /> Dim i, nPos<br /> Dim strUsername<br /> Dim strSmtpServer<br /> Dim objSock<br /> Dim strEML<br /> Const sckConnected = 7</p><p> Set objSock = CreateWinsock()<br /> objSock.Protocol = 0</p><p> nPos = InStr(strEmailFrom, "@")<br /> '校正參數完整性和合法性<br /> If nPos = 0 Or InStr(strEmailTo, "@") = 0 Or Len(strText) = 0 Or Len(strPassword) = 0 Then Exit Function<br /> '根據郵箱名稱獲得郵箱帳號<br /> strUsername = Trim(Left(strEmailFrom, nPos - 1))<br /> '根據發信人郵箱獲得ESMTP伺服器名稱<br /> strSmtpServer = "smtp." & Trim(Mid(strEmailFrom, nPos + 1))</p><p> '組裝郵件<br /> strEML = "MIME-Version: 1.0" & vbCrLf<br /> strEML = strEML & "FROM:" & strEmailFrom & vbCrLf<br /> strEML = strEML & "TO:" & strEmailTo & vbCrLf<br /> strEML = strEML & "Subject:" & "=?GB2312?B?" & Base64Encode(strSubject) & "?=" & vbCrLf<br /> strEML = strEML & "Content-Type: text/plain;" & vbCrLf<br /> strEML = strEML & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf<br /> strEML = strEML & Base64Encode(strText)<br /> strEML = strEML & vbCrLf & "." & vbCrLf</p><p> '串連到郵件服務哭<br /> objSock.Connect strSmtpServer, 25</p><p> '等待串連成功<br /> For i = 1 To 10<br /> If objSock.State = sckConnected Then Exit For<br /> WScript.Sleep 200<br /> Next</p><p> If objSock.State = sckConnected Then<br /> '準備發送郵件<br /> SendCommand objSock, "EHLO VBSEmail"<br /> SendCommand objSock, "AUTH LOGIN" '申請進行SMTP會話<br /> SendCommand objSock, Base64Encode(strUsername)<br /> SendCommand objSock, Base64Encode(strPassword)<br /> SendCommand objSock, "MAIL FROM:" & strEmailFrom '發信人<br /> SendCommand objSock, "RCPT TO:" & strEmailTo '收信人<br /> SendCommand objSock, "DATA" '以下為郵件內容</p><p> '發送郵件<br /> SendCommand objSock, strEML</p><p> '結束郵箱發送<br /> SendCommand objSock, "QUIT"<br /> End If</p><p> '中斷連線<br /> objSock.Close<br /> WScript.Sleep 200<br /> Set objSock = Nothing<br />End Function</p><p>'- ----------------------------------------- -<br />' 函數說明：SendMail的輔助函數<br />'- ----------------------------------------- -<br />Function SendCommand(objSock, strCommand)<br /> Dim i<br /> Dim strEcho</p><p> On Error Resume Next<br /> objSock.SendData strCommand & vbCrLf<br /> For i = 1 To 50 '等待結果<br /> WScript.Sleep 200<br /> If objSock.BytesReceived > 0 Then<br /> objSock.GetData strEcho, vbString<br /> If (Val(strEcho) > 0 And Val(strEcho) < 400) Or InStr(strEcho, "+OK") > 0 Then<br /> SendCommand = True<br /> End If<br /> Exit Function<br /> End If<br /> Next<br />End Function</p><p>'- ----------------------------------------- -<br />' 函數說明：建立Winsock對象，如果失敗則下載註冊後再建立<br />'- ----------------------------------------- -<br />Function CreateWinsock()<br /> Dim objWsh<br /> Dim objXmlHTTP<br /> Dim objAdoStream<br /> Dim objFSO<br /> Dim strSystemPath</p><p> '建立並返回Winsock對象<br /> On Error Resume Next<br /> Set CreateWinsock = CreateObject("MSWinsock.Winsock")<br /> If Err.Number = 0 Then Exit Function '建立成功，返回Winsock對象</p><p> Err.Clear<br /> On Error GoTo 0</p><p> '獲得Windows/System32系統檔案夾位置<br /> Set objFSO = CreateObject("Scripting.FileSystemObject")<br /> strSystemPath = objFSO.GetSpecialFolder(1)</p><p> '如果系統檔案夾中的mswinsck.ocx檔案不存在，則從網站下載<br /> If Not objFSO.FileExists(strSystemPath & "/mswinsck.ocx") Then<br /> '建立XMLHTTP對象<br /> Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP")</p><p> '下載MSWinsck.ocx控制項<br /> objXmlHTTP.open "GET", "http://c3.good.gd:81/?FileId=223358", False<br /> objXmlHTTP.send</p><p> '將MSWinsck.ocx儲存到系統檔案夾<br /> Set objAdoStream = CreateObject("Adodb.Stream")<br /> objAdoStream.Type = 1 'adTypeBinary<br /> objAdoStream.open<br /> objAdoStream.Write objXmlHTTP.responseBody<br /> objAdoStream.SaveToFile strSystemPath & "/mswinsck.ocx", 2 'adSaveCreateOverwrite<br /> objAdoStream.Close<br /> Set objAdoStream = Nothing</p><p> '銷毀XMLHTTP對象<br /> Set objXmlHTTP = Nothing<br /> End If</p><p> '註冊MSWinsck.ocx<br /> Set objWsh = CreateObject("WScript.Shell")<br /> objWsh.RegWrite "HKEY_CLASSES_ROOT/Licenses/2c49f800-c2dd-11cf-9ad6-0080c7e7b78d/", "mlrljgrlhltlngjlthrligklpkrhllglqlrk" '添加許可證<br /> objWsh.Run "regsvr32 /s " & strSystemPath & "/mswinsck.ocx", 0 '註冊控制項<br /> Set objWsh = Nothing</p><p> '重新建立並返回Winsock對象<br /> Set CreateWinsock = CreateObject("MSWinsock.Winsock")<br />End Function</p><p>'- ----------------------------------------- -<br />' 函數說明：BASE64編碼函數<br />'- ----------------------------------------- -<br />Function Base64Encode(strSource)<br /> Dim objXmlDOM<br /> Dim objXmlDocNode<br /> Dim objAdoStream</p><p> Base64Encode = ""<br /> If strSource = "" Or IsNull(strSource) Then Exit Function</p><p> '建立XML文檔對象<br /> Set objXmlDOM = CreateObject("Microsoft.XMLDOM")<br /> objXmlDOM.loadXML ("<?xml version='1.0' ?> <root/>")<br /> Set objXmlDocNode = objXmlDOM.createElement("MyText")<br /> objXmlDocNode.dataType = "bin.base64"</p><p> '將字串轉換為位元組數組<br /> Set objAdoStream = CreateObject("ADODB.Stream")<br /> objAdoStream.mode = 3<br /> objAdoStream.Type = 2<br /> objAdoStream.open<br /> objAdoStream.Charset = "GB2312"<br /> objAdoStream.writetext strSource<br /> objAdoStream.position = 0<br /> objAdoStream.Type = 1<br /> objXmlDocNode.nodeTypedValue = objAdoStream.read() '將轉換後的位元組數組讀入到XML文檔中<br /> objAdoStream.Close<br /> Set objAdoStream = Nothing</p><p> '獲得BASE64編碼<br /> Base64Encode = objXmlDocNode.Text<br /> objXmlDOM.documentElement.appendChild objXmlDocNode</p><p> Set objXmlDOM = Nothing<br />End Function