网站首页  汉语字词  英语词汇  考试资料  写作素材  旧版资料

请输入您要查询的范文：

　

标题 使用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://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
随便看

　

在线学习网范文大全提供好词好句、学习总结、工作总结、演讲稿等写作素材及范文模板，是学习及工作的有利工具。

　

Copyright © 2002-2024 cuapp.net All Rights Reserved
更新时间：2025/5/14 20:30:56