- '* **************************************** *
- '* 程序名称: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
- #该片段来自于http://www.codesnippet.cn/detail/270320149157.html
来源: http://www.codesnippet.cn/detail/270320149157.html