这篇文章主要介绍了使用vbs获得外网ip并发送到邮箱里.

代码如下:

'* **************************************** * 

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

更多信息请查看IT技术专栏