[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

[原创] VBS发送外网IP到QQ邮箱 By Yu2n

本帖最后由 yu2n 于 2019-5-26 19:42 编辑

更新 IP 检测网址为 http://www.bathome.net/s/ip.php  

VBS发送外网IP到QQ邮箱 By Yu2n
功能:如题
说明:网络上这样的代码很多,这个的话,填上你的QQ号码信息,设置好QQ邮箱就能用。
注意,QQ邮箱升级了第三方SMTP接入,此处的密码不是登陆QQ邮箱密码,而是“设置”-“账号”-“POP3/IMAP/SMTP...”-“生成授权码”中生成的授权码,更安全。
  1. 'SendWwwIPToMail@qq.com.vbs
  2. 'VBS发送外网IP到QQ邮箱 By Yu2n
  3. Option Explicit
  4. Const SvrName = "smtp.qq.com"    'SMTP服务器
  5. Const SvrPort = "25"             'SMTP服务器端口
  6. Const Username = "xxx@qq.com"    '邮件用户账号,这里填写你的QQ号码
  7. Const Password = "asdfsdfhlxfdffdfd"  'QQ邮箱SMTP授权码
  8. Const MailFrom = "xxx@qq.com"    '你的邮箱地址,如 QQ号码@qq.com
  9. Const MailTo = "yyy@qq.com"      '对方邮箱地址
  10. Const Subject = "NetCenterIP 当前 IP 为 {当前IP},发送于 {现在时间}"   '使用{当前IP}、{现在时间}标签来获取动态数据
  11. Const Message = "^o^"
  12. Main        
  13. Sub Main()
  14.   Dim CurIP, LastIP, strSubject, strMessage
  15.   Do
  16.     CurIP = GetWWWIP()      '获取当前IP
  17.     If CurIP <> LastIP Then    'IP变化时,发送IP到邮箱
  18.       LastIP = CurIP
  19.       strSubject = Replace(Subject, "{当前IP}", CurIP)
  20.       strSubject = Replace(strSubject, "{现在时间}", FormatDT(Now(),"{y}/{M}/{D} {h}:{n}"))
  21.       strMessage = Replace(Message, "{当前IP}", CurIP)
  22.       strMessage = Replace(strMessage, "{现在时间}", FormatDT(Now(),"{y}/{M}/{D} {h}:{n}"))
  23.       Call SendMail(SvrName, SvrPort, Username, Password, _
  24.         MailFrom, MailTo, strSubject, strMessage)
  25.     End If
  26.     WScript.Sleep 5 * 1000
  27.   Loop
  28. End Sub
  29. '发邮件,可指定附件(文件路径数组)
  30. Function SendMail(strSvrName, strSvrPort, strUsername, strPassword, _
  31.   strFrom, strTo, strSubject, strMessage)
  32.   Const schema = "http://schemas.microsoft.com/cdo/configuration/"
  33.   Dim Check, Email, strAttachment
  34.   Check = False
  35.   On Error Resume Next
  36.   Do Until Check = True
  37.     Set Email = CreateObject("CDO.Message")
  38.     Email.BodyPart.Charset = "utf-8"  '邮件内容编码
  39.     Email.From = strFrom        '发送邮箱地址
  40.     Email.To = strTo          '接收邮箱地址
  41.     Email.Subject = strSubject      '这是邮件主题
  42.     Email.Textbody = strMessage      '这是邮件内容
  43.     With Email.Configuration.Fields
  44.       .Item(schema & "sendusing") = 2
  45.       .Item(schema & "smtpserver") = strSvrName        '这里写SMTP服务器
  46.       .Item(schema & "smtpserverport") = strSvrPort      '这里写SMTP服务器端口
  47.       .Item(schema & "smtpauthenticate") = 1
  48.       .Item(schema & "sendusername") = strUsername      '发送邮箱账号
  49.       .Item(schema & "sendpassword") = strPassword      '发送邮箱密码
  50.       .Item(schema & "smtpconnectiontimeout") = 60 ''300      '服务器连接超时
  51.       .Update
  52.     End With
  53.     Err.Clear
  54.     Email.Send
  55.     If Err.Number = 0 Then Check = True
  56.     Set Email = Nothing
  57.     WScript.Sleep 200
  58.   Loop
  59. End Function
  60. '获取外网IPv4,强制等待获取正确IP
  61. Function GetWWWIP()
  62.   Dim Check, objHttp, strHtml, re
  63.   Check = False
  64.   On Error Resume Next
  65.   Do Until Check = True
  66.     Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
  67.     objHttp.SetTimeouts 5000,5000,5000,5000  'ResolveTimeout,ConnectTimeout,SendTimeout,ReceiveTimeout
  68.     objHttp.Open "GET", "http://www.bathome.net/s/ip.php", False
  69.     objHttp.Send
  70.     If objHttp.Status = 200 Then
  71.       strHtml = objHttp.ResponseText()
  72.       Set re = CreateObject("vbScript.regExp")
  73.       re.Pattern = "(\d+\.\d+\.\d+\.\d+)"
  74.       If re.Test(strHtml) Then
  75.         GetWWWIP = re.Execute(strHtml)(0).SubMatches(0)
  76.         Check = True
  77.       End If
  78.     End If
  79.     Set re = Nothing
  80.     Set objHttp = Nothing
  81.     WScript.Sleep 200
  82.   Loop
  83. End Function
  84. 'FormatDT 日期时间格式化 By Abo(wupwu@qq.com) 2008.09.07
  85. '参数:DateTime 日期时间, Template 格式化模板
  86. '备注:Template 模板标签注释 {Y}:年 {y}:2位年 {M}:月 {m}:补位月,例:01,02 {ME}:英文月份 {Me}:英文月份缩写 {D}:日 {d}:补位日
  87. '{W}:星期几英文 {w}:星期几英文缩写 {H}:时 {h}:补位时 {N}:分 {n}:补位分 {S}:秒 {s}:补位秒
  88. Function FormatDT(DateTime, Template)
  89.   If StringToDate(DateTime) = "" Or Trim(Template) = "" Then FormatDT = Template  : Exit Function
  90.   DateTime = StringToDate(DateTime)
  91.   Dim dtmY,dtmM,dtmD,dtmH ,dtmN,dtmS,dtmW,arrFW,arrSW,arrFM,arrSM
  92.   dtmY=Year(DateTime)  : dtmM=Month(DateTime)  : dtmD=Day(DateTime)  : dtmW=WeekDay(DateTime)
  93.   dtmH=Hour(DateTime)  : dtmN=Minute(DateTime)  : dtmS=Second(DateTime)
  94.   arrFW = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
  95.   arrSW = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
  96.   arrFM = Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
  97.   arrSM = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  98.   Template = Replace(Template,"{Y}",dtmY)  : Template = Replace(Template,"{y}",Right(dtmY,2))
  99.   Template = Replace(Template,"{M}",dtmM)  : Template = Replace(Template,"{m}",Right("00"&dtmM ,2))
  100.   Template = Replace(Template,"{ME}",arrFM(dtmM-1))  : Template = Replace(Template,"{Me}",arrSM(dtmM-1))
  101.   Template = Replace(Template,"{D}",dtmD)  : Template = Replace(Template,"{d}",Right("00"&dtmD,2))
  102.   Template = Replace(Template,"{H}",dtmH )  : Template = Replace(Template,"{h}",Right("00"&dtmH ,2))
  103.   Template = Replace(Template,"{N}",dtmN)  : Template = Replace(Template,"{n}",Right("00"&dtmN,2))
  104.   Template = Replace(Template,"{S}",dtmS)  : Template = Replace(Template,"{s}",Right("00"&dtmS,2))
  105.   Template = Replace(Template,"{W}",arrFW(dtmW-1))  : Template = Replace(Template,"{w}",arrSW(dtmW-1))
  106.   FormatDT = Template
  107. End Function
  108. 'StringToDate 日期字符串转日期 (修正系统日期分隔符不同的问题) By Yu2n 2014.12.10
  109. Function StringToDate(ByVal strDate)   
  110.   If IsDate(strDate) Then StringToDate = CDate(strDate)  : Exit Function
  111.   Dim s1, s2
  112.   For Each s1 In Split(". - /")
  113.     For Each s2 In Split(". - /")
  114.       If IsDate(Replace(strDate,s1,s2)) Then StringToDate = CDate(Replace(strDate,s1,s2))  : Exit Function
  115.     Next
  116.   Next
  117. End Function
复制代码
效果如下:
  1. 邮件标题:NetCenterIP 当前 IP 为 183.22.171.138,发送于 15/11/23 10:52
  2. 邮件内容:^o^
复制代码
1

评分人数

    • CrLf: 授权码技术 + 1
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

你好 这个怎么用 我怎么老是错误

TOP

回复 4# CrLf


    我知道到了。
下载安装python3 https://www.python.org/downloads/ 代码存为xx.py 双击运行或IDLE打开F5运行

TOP

回复 2# 依山居


    绝不会告诉你们 bathome 有返回 ip 的接口
http://www.bathome.net/s/ip.php

TOP

回复 2# 依山居

我的 SAE 挂了,不打算交费了。
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

查看当前外网IP http://my.oschina.net/ysj/blog/511724

我整理了比较多的,可以查看外网IP的网站。
比如像 ip.6655.com/ip.aspx
下载安装python3 https://www.python.org/downloads/ 代码存为xx.py 双击运行或IDLE打开F5运行

TOP

返回列表