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