批處理新手入門導讀[視頻教程]批處理基礎視頻教程[視頻教程]VBS基礎視頻教程
[批處理文件精品]批處理版照片整理器[批處理文件精品]純批處理備份&還原驅動在線第三方下載
返回列表 發帖

[原創] VBS發送外網IP到QQ郵箱 By Yu2n

本帖最后由 yu2n 于 2019-5-26 19:42 編輯

更新 IP 檢測網址為 http://www.54721299.buzz/s/ip.php  

VBS發送外網IP到QQ郵箱 By Yu2n
功能:如題
說明:網絡上這樣的代碼很多,這個的話,填上你的QQ號碼信息,設置好QQ郵箱就能用。
注意,QQ郵箱升級了第三方SMTP接入,此處的密碼不是登陸QQ郵箱密碼,而是“設置”-“賬號”-“POP3/IMAP/SMTP...”-“生成授權碼”中生成的授權碼,更安全。
  1. '[email protected]
  2. 'VBS發送外網IP到QQ郵箱 By Yu2n
  3. Option Explicit
  4. Const SvrName = "smtp.qq.com"    'SMTP服務器
  5. Const SvrPort = "25"             'SMTP服務器端口
  6. Const Username = "[email protected]"    '郵件用戶賬號,這里填寫你的QQ號碼
  7. Const Password = "asdfsdfhlxfdffdfd"  'QQ郵箱SMTP授權碼
  8. Const MailFrom = "[email protected]"    '你的郵箱地址,如 QQ號[email protected]
  9. Const MailTo = "[email protected]"      '對方郵箱地址
  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.54721299.buzz/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([email protected]) 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/

查看當前外網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

回復 2# 依山居

我的 SAE 掛了,不打算交費了。
『千江有水千江月』千江有水,月映千江;萬里無云,萬里青天。    http://yu2n.qiniudn.com/

TOP

回復 2# 依山居


    絕不會告訴你們 bathome 有返回 ip 的接口
http://www.54721299.buzz/s/ip.php

TOP

回復 4# CrLf


    我知道到了。
下載安裝python3 https://www.python.org/downloads/ 代碼存為xx.py 雙擊運行或IDLE打開F5運行

TOP

你好 這個怎么用 我怎么老是錯誤

TOP

返回列表
36选7开奖结果今天福建