本篇内容主要讲解“如何使用vbs获得外网ip并发送到邮箱里”，感兴趣的朋友不妨来看看。本文介绍的方法操作简单快捷，实用性强。下面就让小编来带大家学习“如何使用vbs获得外网ip并发送到邮箱里”吧!

我们提供的服务有：做网站、网站制作、微信公众号开发、网站优化、网站认证、长阳ssl等。为成百上千企事业单位解决了网站和推广的问题。提供周到的售前咨询和贴心的售后服务，是有科学管理、有技术的长阳网站制作公司

复制代码 代码如下:

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

到此，相信大家对“如何使用vbs获得外网ip并发送到邮箱里”有了更深的了解，不妨来实际操作一番吧！这里是创新互联建站，更多相关内容可以进入相关频道进行查询，关注我们，继续学习！

文章题目：如何使用vbs获得外网ip并发送到邮箱里-创新互联
链接URL：http://chengdu.cdxwcx.cn/article/dicecc.html