'* **************************************** *  '* 程序名称：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