自動獲取外網IP并發郵件

Posted 2020-10-08 Bruce_Cheung

問題：

公司有一Web系統需開放給香港Office公司查詢資料，但最近動態域名需實名認證，

因系統較小型，非公開大範圍使用，所以再認證一域名也沒多大必要，

所以想定時生成一封能查詢外網IP的郵件發送給相關同事。

方案：

1.新建一個VBS文件用來獲取IP和發送郵件：

 1 On Error Resume next
 2 
 3 Set objEmail=CreateObject("CDO.Message")
 4 
 5 Call SendMail()
 6 
 7 Sub SendMail
 8     Url="http://www.ip138.com/ips1388.asp"    ‘https://www.baidu.com/s?wd=ip
 9     Set NP = Createobject("Microsoft.XMLHTTP")
10     NP.Open "GET", url, False
11     NP.Send
12     Data=NP.responsebody
13     Set NP = Nothing
14     Data = bytes2BSTR(Data)
15     Here = InstrRev(Data, "ip138.com IP", -1,0)
16     Data = Mid(Data,Here+83,17)
17     Data = Replace(Data, "[","")
18     Data = Replace(Data, "]","")
19     Data = Replace(Data, " ","")
20     Data="This mail send from : " & Data & "." & vbcrlf & "You may use this: http://" & Data & ":8080/MISWeb" & vbCrlf & "Bruce " & Now & vbCrlf
21     ‘WSH.Echo Data
22 
23     objEmail.From="[email protected]"                    ‘Sender
24     objEmail.To="[email protected]"                        ‘Receiver:[email protected]
25     objEmail.Subject="This Mail Only used to Get CCL Factory IP"                        ‘Subject
26     objEmail.Textbody=Data
27     CreateObject("Scripting.FileSystemObject").OpenTextFile("CCLFactoryIP.txt",8,1) _
28         .Write Data
29     ‘WSH.Echo Now & ": " & Data    
30     objEmail.Configuration.Fields.Item _
31         ("http://schemas.microsoft.com/cdo/configuration/sendusing")=2
32     objEmail.Configuration.Fields.Item _
33         ("http://schemas.microsoft.com/cdo/configuration/smtpserver")="ppp.com"     ‘SMTP Server Address
34     objEmail.Configuration.Fields.Item _
35         ("http://schemas.microsoft.com/cdo/configuration/sendusername")="qqq"                        ‘Username
36     objEmail.Configuration.Fields.Item _
37         ("http://schemas.microsoft.com/cdo/configuration/sendpassword")="zzz"                        ‘Password
38     objEmail.Configuration.Fields.Item _
39         ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")=1                    ‘Password use Text
40     objEmail.Configuration.Fields.Item _
41         ("http://schemas.microsoft.com/cdo/configuration/smtpserverport")=25                    ‘Smtp Port
42     objEmail.Configuration.Fields.Update
43     objEmail.Send
44 End Sub
45 Function bytes2BSTR(vIn)
46     strReturn = ""
47     For i = 1 To LenB(vIn)
48         ThisCharCode = AscB(MidB(vIn,i,1))
49         If ThisCharCode < &H80 Then
50             strReturn = strReturn & Chr(ThisCharCode)
51         Else
52             NextCharCode = AscB(MidB(vIn,i+1,1))
53             strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
54             i = i + 1
55         End If
56     Next
57     bytes2BSTR = strReturn
58 End Function

View Code

2.在Win系統設置定時任務：

Win10: 開始->Windows管理工具->任務計劃程序，操作->創建基本任務，輸入名稱，設定每周一到周五8：58開始，每一小時運行一次，持續8小時。

3.測試完全OK。

【轉載請註明來源】