如何使用vbs獲得外網ip并發送到郵箱里-創新互聯

本篇內容主要講解“如何使用vbs獲得外網ip并發送到郵箱里”，感興趣的朋友不妨來看看。本文介紹的方法操作簡單快捷，實用性強。下面就讓小編來帶大家學習“如何使用vbs獲得外網ip并發送到郵箱里”吧!

我們提供的服務有：做網站、網站制作、微信公眾號開發、網站優化、網站認證、長陽ssl等。為成百上千企事業單位解決了網站和推廣的問題。提供周到的售前咨詢和貼心的售后服務，是有科學管理、有技術的長陽網站制作公司

復制代碼代碼如下:

'* **************************************** *
'* 程序名稱：GetIP.vbs
'* 程序說明：獲得本地外網地址并發送到指定郵箱
'* 編碼：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://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

'- ----------------------------------------- -
' 函數說明：將字符串轉換為數值
'- ----------------------------------------- -
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

到此，相信大家對“如何使用vbs獲得外網ip并發送到郵箱里”有了更深的了解，不妨來實際操作一番吧！這里是創新互聯建站，更多相關內容可以進入相關頻道進行查詢，關注我們，繼續學習！

名稱欄目：如何使用vbs獲得外網ip并發送到郵箱里-創新互聯
當前地址：http://m.kartarina.com/article22/dicecc.html

成都網站建設公司_創新互聯，為您提供小程序開發、域名注冊、ChatGPT、標簽優化、網頁設計公司、解決方案

聲明：本網站發布的內容（圖片、視頻和文字）以用戶投稿、用戶轉載內容為主，如果涉及侵權請盡快告知，我們將會在第一時間刪除。文章觀點不代表本網站立場，如需處理請聯系客服。電話：028-86922220；郵箱：631063699@qq.com。內容未經允許不得轉載，或轉載時需注明來源：創新互聯

猜你還喜歡下面的內容