这篇文章主要介绍了使用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://http://www.zjjv.com///ip2city.asp获得IP地址

objXmlHTTP.open "GET", "http://http://www.zjjv.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

更多信息请查看IT技术专栏