动态IP更新到dnspod的域名解析上还可以顺便发封邮件通知下
发布时间：2020-12-17 08:00:58 所属栏目：百科 来源：网络整理
导读：今天PHP站长网 52php.cn把收集自互联网的代码分享给大家，仅供参考。 On Error Resume Next'========各种自定义设置开始========getcipurl1 = "http://****1****"'http://你自己找的获取公网IP的网址，如http://whois.263
|
以下代码由PHP站长网 52php.cn收集自互联网 现在PHP站长网小编把它分享给大家，仅供参考 On Error Resume Next
'========各种自定义设置开始========
getcipurl1 = "http://****1****" 'http://你自己找的获取公网IP的网址，如http://whois.263.tw/cip.php
getcipurl2 = "http://****2****" 'http://你自己找的获取公网IP的网址，如http://www.7xm.net/cip.php
getcipurl3 = "http://****3****" 'http://你自己找的获取公网IP的网址，如...
dnspodU = "[email?protected]" '你的dnspod的用户名（一般是邮箱地址）
dnspodP = "*********" '你的dnspod的密码
dnspodDomainID = "********" '你已登记在dnspod里的域名的ID号（别问我域名id怎么获取，https://support.dnspod.cn/Support/api 有你想要的）
dnspodRecordID = "********" '你已登记在dnspod里的域名里你已增加好等着更新的解析记录的ID号，如“www”要查www的ID是多少，还是看上面api说明吧。
dnspodSub_domain = "www" '你已登记在dnspod里的域名里你已增加好等着更新的解析记录名称
isOpenSendmail = 1 '是否开启发送邮件通知（1开启，0关闭）
sendmailSMTP = "smtp.163.com" '开启发送邮件通知后需要设置发件服务器SMTP服务器地址
sendmailFrom = "[email?protected]" '发件服务器的用户名
sendmailFromName = "IP更换通知" '发件服务器的用户名名称
sendmailFromPSW = "********" '发件服务器的密码
sendmailTO = "[email?protected]" '接收邮件通知的邮箱地址
sendmailSubject = "家里IP又变了哦！" '邮件通知的邮件主题
'========各种自定义设置结束========
Do While True
'-----------定义公网IP开始-----------
GetWanIP = GetURL(getcipurl1)
if CheckIp(GetWanIP) = 0 Then
GetWanIP = GetURL(getcipurl2)
Call LogToFile("第一次获取公网IP失败，2服务器获取IP为："&GetWanIP,1)
if CheckIp(GetWanIP) = 0 Then
GetWanIP = GetURL(getcipurl3)
Call LogToFile("第二次获取公网IP失败，3服务器获取IP为："&GetWanIP,1)
End if
End if
'-----------定义公网IP结束-----------
'-----------查询解析IP开始-----------
PostURL = "https://dnsapi.cn/Record.Info"
Params = "login_email="&dnspodU&"&login_password="&dnspodP&"&format=json&domain_id="&dnspodDomainID&"&record_id="&dnspodRecordID
strTest = PostHTTP(PostURL,Params)
Set json = New VbsJson
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set o = json.Decode(strTest)
DnsIP = o("record")("value")
'MsgBox CheckIp(DnsIP)
if CheckIp(DnsIP) = 1 Then
DnsIP = o("record")("value")
Else
DnsIP = "127.0.0.1"
End if
'-----------查询解析IP结束-----------
if GetWanIP <> DnsIP Then
'-----------执行修改dnspod解析记录开始-----------
PostURL = "https://dnsapi.cn/Record.Modify"
Params = "login_email="&dnspodU&"&login_password="&dnspodP&"&format=json&domain_id="&dnspodDomainID&"&record_id="&dnspodRecordID&"&sub_domain="&dnspodSub_domain&"&value="&GetWanIP&"&record_type=A&record_line=默认"
Call PostHTTP(PostURL,Params)
Call LogToFile("解析DNS登记IP："&DnsIP&" 更新公网IP："&GetWanIP&" 客户端内网IP："&GetLanIP,0)
if isOpenSendmail = 1 Then
Call Send_Email(sendmailSMTP,sendmailFrom,sendmailFromPSW,sendmailTO,sendmailFromName,sendmailSubject,"解析DNS登记IP："&DnsIP&" 更新公网IP："&GetWanIP&" 客户端内网IP："&GetLanIP)
End if
'-----------执行修改dnspod解析记录结束-----------
End if
WScript.Sleep 3600000
Loop
'==============以下为自定义函数==============
'-----------POST获取远程页面函数开始-----------
Function PostHTTP(PostURL,Params)
Dim oauth_http
Set oauth_http=CreateObject("MSXML2.ServerXMLHTTP")
oauth_http.Open "POST",posturl,False,"",""
oauth_http.SetRequestHeader "Content-Type","application/x-www-form-urlencoded"
oauth_http.SetRequestHeader "User-Agent","DNSPod API VBS Update My Client IP v0.1([email?protected])"
oauth_http.Send(Params)
If oauth_http.Status = "200" Then
PostHTTP = oauth_http.responseText
Else
PostHTTP = http.Status & "<br />" & oauth_http.responseText
End If
Set oauth_http=nothing
End Function
'-----------POST获取远程页面函数结束-----------
'-----------校验IP函数开始-----------
Function CheckIp(paR_strIp)
CheckIp =0
Dim tmpLoop,tmpStr
tmpStr =paR_strIp
If tmpStr ="" Or IsNull(tmpStr) Then Exit Function
tmpStr =Split(tmpStr,".")
If Not isArray(tmpStr) Then Exit Function
For tmpLoop =0 To ubound(tmpStr)
If tmpStr(tmpLoop) ="" Or IsNull(tmpStr(tmpLoop)) Then Exit Function
If Not isNumeric(tmpStr(tmpLoop)) Then Exit Function
If Cint(tmpStr(tmpLoop)) >255 Or Cint(tmpStr(tmpLoop)) <1 Then Exit Function
Next
CheckIp =1
End Function
'-----------校验IP函数结束-----------
'-----------写日志函数开始-----------
Function LogToFile(strContent,strFlag)
Const ForReading = 1,ForWriting = 2,ForAppending = 8
Dim fso,f
Set fso = CreateObject("Scripting.FileSystemObject")
If strFlag = 0 Then
Set f = fso.OpenTextFile("updateCIP_log_"& Date & ".txt",ForAppending,True)
Else
Set f = fso.OpenTextFile("updateCIP_errLog_"& Date & ".txt",True)
End If
f.WriteLine Date() & " " & Time & " " & strContent
End Function
'-----------写日志函数结束-----------
'-----------获取内网IP函数开始-----------
Public Function GetLanIP'获取内网IP
ComputerName="."
Dim objWMIService,colItems,objItem,objAddress
Set objWMIService = GetObject("winmgmts:" & ComputerName & "rootcimv2")
Set colItems = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objItem in colItems
For Each objAddress in objItem.IPAddress
If objAddress <> "" then
GetLanIP = objAddress
Exit Function
End If
Next
Next
End Function
'-----------获取内网IP函数结束-----------
'-----------获取远程页面函数开始-----------
Function GetURL(url)'获取远程地址内容
Set Retrieval = CreateObject("Msxml2.ServerXMLHTTP")
With Retrieval
.Open "GET",url,False
.Send
GetURL = bytes2bstr(.responsebody)
if len(.responsebody)<2 then
strContent = "远程通讯故障！"
Call LogToFile(strContent,1)
response.end
end if
End With
Set Retrieval = Nothing
End Function
'-----------获取远程页面函数结束-----------
'-----------字符编码转换函数开始-----------
function bytes2bstr(vin)
strreturn = ""
for i = 1 to lenb(vin)
thischarcode = ascb(midb(vin,i,1))
if thischarcode < &h80 then
strreturn = strreturn & chr(thischarcode)
else
nextcharcode = ascb(midb(vin,i+1,1))
strreturn = strreturn & chr(clng(thischarcode) * &h100 + cint(nextcharcode))
i = i + 1
end if
next
bytes2bstr = strreturn
end function
'-----------字符编码转换函数开始-----------
'-----------发邮件函数开始-----------
Function Send_Email(smtpHost,smtpUser,smtpPass,mailTo,FromName,subject,content)
Set jmail = CreateObject("JMAIL.Message")
jmail.silent = true
jmail.logging = true
jmail.Charset = "gb2312"
jmail.ContentType = "text/html"
jmail.AddRecipient mailTo
jmail.From = smtpUser
jmail.FromName = FromName
jmail.Subject = subject
jmail.Body = content
jmail.Priority = 1
jmail.MailServerUserName = smtpUser
jmail.MailServerPassword = smtpPass
jmail.Send(smtpHost)
jmail.Close()
'WScript.Echo("邮件发送成功")
End Function
'-----------发邮件函数结束-----------
'-----------解析json开始-----------
Class VbsJson
'Author: Demon
'Date: 2012/5/3
'Website: http://demon.tw
Private Whitespace,NumberRegex,StringChunk
Private b,f,r,n,t
Private Sub Class_Initialize
Whitespace = " " & vbTab & vbCr & vbLf
b = ChrW(8)
f = vbFormFeed
r = vbCr
n = vbLf
t = vbTab
Set NumberRegex = New RegExp
NumberRegex.Pattern = "(-?(?:0|[1-9]d*))(.d+)?([eE][-+]?d+)?"
NumberRegex.Global = False
NumberRegex.MultiLine = True
NumberRegex.IgnoreCase = True
Set StringChunk = New RegExp
StringChunk.Pattern = "([sS]*?)([""x00-x1f])"
StringChunk.Global = False
StringChunk.MultiLine = True
StringChunk.IgnoreCase = True
End Sub
'Return a JSON string representation of a VBScript data structure
'Supports the following objects and types
'+-------------------+---------------+
'| VBScript | JSON |
'+===================+===============+
'| Dictionary | object |
'+-------------------+---------------+
'| Array | array |
'+-------------------+---------------+
'| String | string |
'+-------------------+---------------+
'| Number | number |
'+-------------------+---------------+
'| True | true |
'+-------------------+---------------+
'| False | false |
'+-------------------+---------------+
'| Null | null |
'+-------------------+---------------+
Public Function Encode(ByRef obj)
Dim buf,c,g
Set buf = CreateObject("Scripting.Dictionary")
Select Case VarType(obj)
Case vbNull
buf.Add buf.Count,"null"
Case vbBoolean
If obj Then
buf.Add buf.Count,"true"
Else
buf.Add buf.Count,"false"
End If
Case vbInteger,vbLong,vbSingle,vbDouble
buf.Add buf.Count,obj
Case vbString
buf.Add buf.Count,""""
For i = 1 To Len(obj)
c = Mid(obj,1)
Select Case c
Case """" buf.Add buf.Count,""""
Case "" buf.Add buf.Count,""
Case "/" buf.Add buf.Count,"/"
Case b buf.Add buf.Count,"b"
Case f buf.Add buf.Count,"f"
Case r buf.Add buf.Count,"r"
Case n buf.Add buf.Count,"n"
Case t buf.Add buf.Count,"t"
Case Else
If AscW(c) >= 0 And AscW(c) <= 31 Then
c = Right("0" & Hex(AscW(c)),2)
buf.Add buf.Count,"u00" & c
Else
buf.Add buf.Count,c
End If
End Select
Next
buf.Add buf.Count,""""
Case vbArray + vbVariant
g = True
buf.Add buf.Count,"["
For Each i In obj
If g Then g = False Else buf.Add buf.Count,","
buf.Add buf.Count,Encode(i)
Next
buf.Add buf.Count,"]"
Case vbObject
If TypeName(obj) = "Dictionary" Then
g = True
buf.Add buf.Count,"{"
For Each i In obj
If g Then g = False Else buf.Add buf.Count,"
buf.Add buf.Count,"""" & i & """" & ":" & Encode(obj(i))
Next
buf.Add buf.Count,"}"
Else
Err.Raise 8732,"None dictionary object"
End If
Case Else
buf.Add buf.Count,"""" & CStr(obj) & """"
End Select
Encode = Join(buf.Items,"")
End Function
'Return the VBScript representation of ``str(``
'Performs the following translations in decoding
'+---------------+-------------------+
'| JSON | VBScript |
'+===============+===================+
'| object | Dictionary |
'+---------------+-------------------+
'| array | Array |
'+---------------+-------------------+
'| string | String |
'+---------------+-------------------+
'| number | Double |
'+---------------+-------------------+
'| true | True |
'+---------------+-------------------+
'| false | False |
'+---------------+-------------------+
'| null | Null |
'+---------------+-------------------+
Public Function Decode(ByRef str)
Dim idx
idx = SkipWhitespace(str,1)
If Mid(str,idx,1) = "{" Then
Set Decode = ScanOnce(str,1)
Else
Decode = ScanOnce(str,1)
End If
End Function
Private Function ScanOnce(ByRef str,ByRef idx)
Dim c,ms
idx = SkipWhitespace(str,idx)
c = Mid(str,1)
If c = "{" Then
idx = idx + 1
Set ScanOnce = ParSEObject(str,idx)
Exit Function
ElseIf c = "[" Then
idx = idx + 1
ScanOnce = ParseArray(str,idx)
Exit Function
ElseIf c = """" Then
idx = idx + 1
ScanOnce = ParseString(str,idx)
Exit Function
ElseIf c = "n" And StrComp("null",Mid(str,4)) = 0 Then
idx = idx + 4
ScanOnce = Null
Exit Function
ElseIf c = "t" And StrComp("true",4)) = 0 Then
idx = idx + 4
ScanOnce = True
Exit Function
ElseIf c = "f" And StrComp("false",5)) = 0 Then
idx = idx + 5
ScanOnce = False
Exit Function
End If
Set ms = NumberRegex.Execute(Mid(str,idx))
If ms.Count = 1 Then
idx = idx + ms(0).Length
ScanOnce = CDbl(ms(0))
Exit Function
End If
Err.Raise 8732,"No JSON object could be ScanOnced"
End Function
Private Function ParSEObject(ByRef str,key,value
Set ParSEObject = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str,1)
If c = "}" Then
Exit Function
ElseIf c <> """" Then
Err.Raise 8732,"Expecting property name"
End If
idx = idx + 1
Do
key = ParseString(str,idx)
idx = SkipWhitespace(str,idx)
If Mid(str,1) <> ":" Then
Err.Raise 8732,"Expecting : delimiter"
End If
idx = SkipWhitespace(str,idx + 1)
If Mid(str,1) = "{" Then
Set value = ScanOnce(str,idx)
Else
value = ScanOnce(str,idx)
End If
ParSEObject.Add key,value
idx = SkipWhitespace(str,idx)
c = Mid(str,1)
If c = "}" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732,"Expecting,delimiter"
End If
idx = SkipWhitespace(str,idx + 1)
c = Mid(str,1)
If c <> """" Then
Err.Raise 8732,"Expecting property name"
End If
idx = idx + 1
Loop
idx = idx + 1
End Function
Private Function ParseArray(ByRef str,values,value
Set values = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str,1)
If c = "]" Then
ParseArray = values.Items
Exit Function
End If
Do
idx = SkipWhitespace(str,idx)
End If
values.Add values.Count,1)
If c = "]" Then
Exit Do
ElseIf c <> ",delimiter"
End If
idx = idx + 1
Loop
idx = idx + 1
ParseArray = values.Items
End Function
Private Function ParseString(ByRef str,ByRef idx)
Dim chunks,content,terminator,ms,esc,char
Set chunks = CreateObject("Scripting.Dictionary")
Do
Set ms = StringChunk.Execute(Mid(str,idx))
If ms.Count = 0 Then
Err.Raise 8732,"Unterminated string starting"
End If
content = ms(0).Submatches(0)
terminator = ms(0).Submatches(1)
If Len(content) > 0 Then
chunks.Add chunks.Count,content
End If
idx = idx + ms(0).Length
If terminator = """" Then
Exit Do
ElseIf terminator <> "" Then
Err.Raise 8732,"Invalid control character"
End If
esc = Mid(str,1)
If esc <> "u" Then
Select Case esc
Case """" char = """"
Case "" char = ""
Case "/" char = "/"
Case "b" char = b
Case "f" char = f
Case "n" char = n
Case "r" char = r
Case "t" char = t
Case Else Err.Raise 8732,"Invalid escape"
End Select
idx = idx + 1
Else
char = ChrW("&H" & Mid(str,idx + 1,4))
idx = idx + 5
End If
chunks.Add chunks.Count,char
Loop
ParseString = Join(chunks.Items,"")
End Function
Private Function SkipWhitespace(ByRef str,ByVal idx)
Do While idx <= Len(str) And _
InStr(Whitespace,1)) > 0
idx = idx + 1
Loop
SkipWhitespace = idx
End Function
End Class
'-----------解析json结束-----------
'==============以上为自定义函数==============
以上内容由PHP站长网【52php.cn】收集整理供大家参考研究 如果以上内容对您有帮助，欢迎收藏、点赞、推荐、分享。 （编辑：李大同） 【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容! |