使用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