On Error Resume Next
 
'========各种自定义设置开始========
getcipurl1 = "http://members.3322.org/dyndns/getip"     'http://你自己找的获取公网IP的网址，如http://whois.263.tw/cip.php
getcipurl2 = "http://ip.xiwaer.com"     'http://你自己找的获取公网IP的网址，如http://www.7xm.net/cip.php
getcipurl3 = "http://whois.263.tw/cip.php"     'http://你自己找的获取公网IP的网址，如...
dnspodU = "123445@126.com"          '你的dnspod的用户名（一般是邮箱地址）
dnspodP = "123456"           '你的dnspod的密码
dnspodDomainID = "11111"     '你已登记在dnspod里的域名的ID号（别问我域名id怎么获取，https://support.dnspod.cn/Support/api 有你想要的）
dnspodRecordID = "1111"     '你已登记在dnspod里的域名里你已增加好等着更新的解析记录的ID号，如“www”要查www的ID是多少，还是看上面api说明吧。
dnspodSub_domain = "nas"        '你已登记在dnspod里的域名里你已增加好等着更新的解析记录名称
 
isOpenSendmail = 1          '是否开启发送邮件通知（1开启，0关闭）
sendmailSMTP = "smtp.21cn.com"       '开启发送邮件通知后需要设置发件服务器SMTP服务器地址
sendmailFrom = "1111@21cn.com"        '发件服务器的用户名
sendmailFromName = "1111@21cn.com"     '发件服务器的用户名名称
sendmailFromPSW = "111111"        '发件服务器的密码
sendmailTO = "311112@qq.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结束-----------
 
'==============以上为自定义函数==============