代码如下:
'* **************************************** *
'* 程序名称：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