使用vbs獲得外網ip并發送到郵箱里

2020-07-26 11:47:23

字體：大中小

來源：轉載

供稿：網友

獲得本地外網地址并發送到指定郵箱，還可以參考這個文章http://www.49028c.com/article/40064.htm

復制代碼代碼如下:

'* **************************************** *
'* 程序名稱：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