濮阳杆衣贸易有限公司

主頁 > 知識(shí)庫 > 使用vbs獲得外網(wǎng)ip并發(fā)送到郵箱里

使用vbs獲得外網(wǎng)ip并發(fā)送到郵箱里

熱門標(biāo)簽:佛山真人電銷機(jī)器人廠家 百度地圖標(biāo)注點(diǎn)距離代碼 齊齊哈爾高德地圖標(biāo)注店 如何用機(jī)器人進(jìn)行電銷 東營快遞外呼系統(tǒng) 哪里有便宜的地圖標(biāo)注公司 地圖標(biāo)注政府哪個(gè)部門管 神行者美術(shù)館地圖標(biāo)注 除了地圖標(biāo)注還有這種生意嗎

獲得本地外網(wǎng)地址并發(fā)送到指定郵箱,還可以參考這個(gè)文章https://www.jb51.net/article/40064.htm

復(fù)制代碼 代碼如下:

'* **************************************** * 
'* 程序名稱: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è)置起始時(shí)間 

    '獲得運(yùn)行實(shí)例數(shù),如果大于1,則結(jié)束以前運(yùn)行的實(shí)例 
    Set objWsh = CreateObject("WScript.Shell") 
    Set objEnv = CreateObject("WScript.Shell").Environment("System") 
    nInstance = Val(objEnv("GetIpToEmail")) + 1 '運(yùn)行實(shí)例數(shù)加1 
    objEnv("GetIpToEmail") = nInstance 
    If nInstance > 1 Then Exit Sub '如果運(yùn)行實(shí)例數(shù)大于1則退出,以防重復(fù)運(yùn)行 

    '開啟遠(yuǎn)程桌面 
    'EnabledRometeDesktop True, Null 

    '在后臺(tái)連續(xù)檢測外網(wǎng)地址,如果有變化則發(fā)送郵件到指定郵箱 
    Do 
        If Err.Number > 0 Then Exit Do 
        If DateDiff("n", dtStartTime, Now) >= 30 Then '半小時(shí)檢查一次IP 
            dtStartTime = Now '重置起始時(shí)間 
            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 '延時(shí)2秒,以釋放CPU資源 
    Loop Until Val(objEnv("GetIpToEmail")) > 1 
    objEnv.Remove "GetIpToEmail" '清除運(yùn)行實(shí)例數(shù)變量 
    Set objEnv = Nothing 
    Set objWsh = Nothing 

    MsgBox "程序被成功終止!", 64, "提示" 
End Sub 

'- ----------------------------------------- - 
' 函數(shù)說明:開啟遠(yuǎn)程桌面 
' 參數(shù)說明:blnEnabled是否開啟,True開啟,F(xiàn)alse關(guān)閉 
'           nPort遠(yuǎn)程桌面的端口號(hào),默認(rèn)為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") 
    '開啟遠(yuǎn)程桌面并設(shè)置端口號(hào) 
    objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/fDenyTSConnections", blnEnabled, "REG_DWORD" '開啟遠(yuǎn)程桌面 
    '設(shè)置遠(yuǎn)程桌面端口號(hào) 
    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") 

    '導(dǎo)航至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:郵件標(biāo)題 
'           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, "@") 
    '校驗(yàn)參數(shù)完整性和合法性 
    If nPos = 0 Or InStr(strEmailTo, "@") = 0 Or Len(strText) = 0 Or Len(strPassword) = 0 Then Exit Function 
    '根據(jù)郵箱名稱獲得郵箱帳號(hào) 
    strUsername = Trim(Left(strEmailFrom, nPos - 1)) 
    '根據(jù)發(fā)信人郵箱獲得ESMTP服務(wù)器名稱 
    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 

    '連接到郵件服務(wù)哭 
    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 
        '準(zhǔn)備發(fā)送郵件 
        SendCommand objSock, "EHLO VBSEmail" 
        SendCommand objSock, "AUTH LOGIN" '申請進(jìn)行SMTP會(huì)話 
        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

您可能感興趣的文章:
  • C# 郵箱mail 發(fā)送類
  • c#調(diào)用qq郵箱smtp發(fā)送郵件修改版代碼分享
  • 獲取外網(wǎng)IP并發(fā)送到指定郵箱的vbs代碼[已測]
  • Java基于JavaMail實(shí)現(xiàn)向QQ郵箱發(fā)送郵件
  • Python實(shí)現(xiàn)給qq郵箱發(fā)送郵件的方法
  • VBS獲取外網(wǎng)IP地址并發(fā)送到指定郵箱的代碼
  • 在Laravel框架里實(shí)現(xiàn)發(fā)送郵件實(shí)例(郵箱驗(yàn)證)
  • java實(shí)現(xiàn)163郵箱發(fā)送郵件到qq郵箱成功案例
  • C#發(fā)送郵箱實(shí)現(xiàn)代碼

標(biāo)簽:銅川 鶴壁 西安 文山 四平 湖州 邢臺(tái)

巨人網(wǎng)絡(luò)通訊聲明:本文標(biāo)題《使用vbs獲得外網(wǎng)ip并發(fā)送到郵箱里》,本文關(guān)鍵詞  使用,vbs,獲得,外網(wǎng),并發(fā),;如發(fā)現(xiàn)本文內(nèi)容存在版權(quán)問題,煩請?zhí)峁┫嚓P(guān)信息告之我們,我們將及時(shí)溝通與處理。本站內(nèi)容系統(tǒng)采集于網(wǎng)絡(luò),涉及言論、版權(quán)與本站無關(guān)。
  • 相關(guān)文章
  • 下面列出與本文章《使用vbs獲得外網(wǎng)ip并發(fā)送到郵箱里》相關(guān)的同類信息!
  • 本頁收集關(guān)于使用vbs獲得外網(wǎng)ip并發(fā)送到郵箱里的相關(guān)信息資訊供網(wǎng)民參考!
  • 推薦文章
    许昌市| 图们市| 佛教| 遂川县| 汾西县| 平罗县| 桑日县| 万源市| 修水县| 白朗县| 海门市| 乐都县| 仙居县| 江川县| 新河县| 遂川县| 犍为县| 乌兰县| 两当县| 乌拉特前旗| 临沧市| 赤水市| 枣庄市| 永济市| 泾阳县| 株洲县| 博罗县| 澄江县| 甘德县| 马尔康县| 西林县| 德阳市| 枞阳县| 孟村| 横峰县| 吉木萨尔县| 文昌市| 屯留县| 柳林县| 白山市| 平山县|