VBS获得外网IP并发送到指定邮箱

    放假了，手头还有些工作要做，又不愿去办公室，于是开启了远程桌面，但又怕网络掉线重连后IP变了，所以编写了这个VBS脚本程序。这个程序主要实现了获得本地外网地址（如果有路由器，则为路由器外网地址）、自动下载并注册MSWinsck.ocx控件、使用WinSock发送邮件、实现BASE64编码、开启远程桌面服务、脚本后台定时运行等功能，感兴趣的朋友可以参见代码，注释写得比较详细，在此就不一一描述了。

    此外，还有一点感言，虽然眼下.NET大行其道，VB6已日渐势微，连带VBS也被人弃如蔽履，但我总以为，基于COM核心的VB，在一些工具性软件开发上，有着其不可比拟的优势。

    使用说明：

    一、用记事本新建一个文本，复制以下代码。

    二、修改邮件为朋友自己的邮箱，然后另存为GetIP.VBS文件。

    三、双击GetIP.VBS文件，即可在后台运行，再次双击后，将结束运行。

    四、其它：本代码只对新浪邮箱进行了测试，其它邮箱朋友们自行修改测试。

 

'* **************************************** *
'* 程序名称：GetIP.vbs
'* 程序说明：获得本地外网地址并发送到指定邮箱
'* 编码：lyserver
'* 联系方式：http://blog.csdn.net/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://www.ip138.com/ip2city.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