代碼如下:

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

'* 程序名稱：getip.vbs

'* 程序說明：獲得本地外網地址并發(fā)送到指定郵箱

'* 編碼：lyserver

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

option explicit

call main '執(zhí)行入口函數

'- ----------------------------------------- -

' 函數說明：程序入口

'- ----------------------------------------- -

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

'在后臺連續(xù)檢測外網地址，如果有變化則發(fā)送郵件到指定郵箱

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發(fā)生了變化則發(fā)送

sendmail 發(fā)信人郵箱@sina.com, 密碼, 收信人郵箱@sina.com, 路由器ip, strnewip '發(fā)送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

'創(chuàng)建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

'- ----------------------------------------- -

' 函數說明：發(fā)送郵件

' 參數說明：stremailfrom：發(fā)信人郵箱

' strpassword：發(fā)信人郵箱密碼

' 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))

'根據發(fā)信人郵箱獲得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

'準備發(fā)送郵件

sendcommand objsock, ehlo vbsemail

sendcommand objsock, auth login '申請進行smtp會話

sendcommand objsock, base64encode(strusername)

sendcommand objsock, base64encode(strpassword)

sendcommand objsock, mail from: & stremailfrom '發(fā)信人

sendcommand objsock, rcpt to: & stremailto '收信人

sendcommand objsock, data '以下為郵件內容

'發(fā)送郵件

sendcommand objsock, streml

'結束郵箱發(fā)送

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

'- ----------------------------------------- -

' 函數說明：創(chuàng)建winsock對象，如果失敗則下載注冊后再創(chuàng)建

'- ----------------------------------------- -

function createwinsock()

dim objwsh

dim objxmlhttp

dim objadostream

dim objfso

dim strsystempath

'創(chuàng)建并返回winsock對象

on error resume next

set createwinsock = createobject(mswinsock.winsock)

if err.number = 0 then exit function '創(chuàng)建成功，返回winsock對象

err.clear

on error goto 0

'獲得windows/system32系統(tǒng)文件夾位置

set objfso = createobject(scripting.filesystemobject)

strsystempath = objfso.getspecialfolder(1)

'如果系統(tǒng)文件夾中的mswinsck.ocx文件不存在，則從網站下載

if not objfso.fileexists(strsystempath & /mswinsck.ocx) then

'創(chuàng)建xmlhttp對象

set objxmlhttp = createobject(msxml2.xmlhttp)

'下載mswinsck.ocx控件

objxmlhttp.open get, , false

objxmlhttp.send

'將mswinsck.ocx保存到系統(tǒng)文件夾

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

'重新創(chuàng)建并返回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

'創(chuàng)建xml文檔對象

set objxmldom = createobject(microsoft.xmldom)

objxmldom.loadxml (<?xml version='1.0' ?> <root/>)

set objxmldocnode = objxmldom.createelement(mytext)

objxmldocnode.datatype = bin.base64

'將字符串轉換為字節(jié)數組

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() '將轉換后的字節(jié)數組讀入到xml文檔中

objadostream.close

set objadostream = nothing

'獲得base64編碼

base64encode = objxmldocnode.text

objxmldom.documentelement.appendchild objxmldocnode

set objxmldom = nothing

end function