代码如下:

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

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