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 = "abc@123.cn" '你的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 = "abc@163.com" '发件服务器的用户名
sendmailFromName = "IP更换通知" '发件服务器的用户名名称
sendmailFromPSW = "********" '发件服务器的密码
sendmailTO = "123@163.com" '接收邮件通知的邮箱地址
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(info8@126.com)"
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", ForAppending, 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 & "\root\cimv2")
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 = "([\s\S]*?)([""\\\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, i, 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, i, 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, idx, 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, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = Null
Exit Function
ElseIf c = "t" And StrComp("true", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = True
Exit Function
ElseIf c = "f" And StrComp("false", Mid(str, idx, 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, ByRef idx)
Dim c, key, value
Set ParseObject = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 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, idx, 1) <> ":" Then
Err.Raise 8732,,"Expecting : delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
If Mid(str, idx, 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, idx, 1)
If c = "}" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732,,"Expecting , delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
c = Mid(str, idx, 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, ByRef idx)
Dim c, values, value
Set values = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "]" Then
ParseArray = values.Items
Exit Function
End If
Do
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
values.Add values.Count, value
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "]" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732,,"Expecting , 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, idx, 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, Mid(str, idx, 1)) > 0
idx = idx + 1
Loop
SkipWhitespace = idx
End Function
End Class
'-----------解析json结束-----------
'==============以上为自定义函数==============
