使用vbs获得外网ip并发送到邮箱里

获得本地外网地址并发送到指定邮箱，还可以参考这个文章http://www.jb51.net/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