作成 2010.01.07
更新 2010.01.18
VBScript で DDNS を登録する
http://ieserver.net/
タスクスケジューラに登録する場合は、10分間隔以上空けることを推奨
実際に登録が反映されるのに最大8分程度かかるため。
あと、Windows Server 2008 R2では最上位の特権で実行するをオンにしないとローカルファイルに書き込めないので改良の必要がある。
Option Explicit
Const USER_NAME = "user_name"
Const DOMAIN_NAME = "domain_name"
Const PASSWORD = "password"
Const TIMEOUT = 10
Const REMOTE_CHECK = "http://ieserver.net/ipcheck.shtml"
Const UPDATE_URL = "https://ieserver.net/cgi-bin/dip.cgi"
Const PREV_FILE = "C:\temp\prev.txt"
Const evError = 1
Const evInfo = 4
Const ForReading = 1
Const ForWriting = 2

Dim objIE, FSO, WshShell
Dim countdown, CurText, PrevText
Dim ChangeFlag, objFile, objRead, objWrite, objIPExp
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate REMOTE_CHECK
countdown = TIMEOUT
Do While objIE.Busy Or objIE.readystate <> 4
  WScript.Sleep 1000
  countdown = countdown - 1
  If countdown <= 0 Then Exit Do
Loop

If countdown <= 0 Then
  WshShell.LogEvent evError, REMOTE_CHECK & " Timeout."
  objIE.Quit
  WScript.Quit
End If
CurText = objIE.Document.body.innerText

Set objIPExp = New RegExp
objIPExp.Pattern = "^\d+\.\d+\.\d+\.\d+$"
objIPExp.Global = False
objIPExp.IgnoreCase = False
CurText = Trim(CurText)
If Not objIPExp.Test(CurText) Then
  WshShell.LogEvent evError, "Check Error: " & CurText
  WScript.Quit
End If

ChangeFlag = False
If Not FSO.FileExists( PREV_FILE ) Then
  PrevText = "Nothing"
  ChangeFlag = True
Else
  Set objFile = FSO.GetFile( PREV_FILE )
  If objFile.DateLastModified < Now - 1 Then
    PrevText = "Too Old"
    ChangeFlag = True
  Else
    Set objRead = FSO.OpenTextFile( PREV_FILE, ForReading )
    PrevText = objRead.ReadAll
    objRead.Close
    If Not PrevText = CurText Then
      ChangeFlag = True
    End If
  End If
End If
If ChangeFlag Then
  objIE.Navigate UPDATE_URL & "?username=" & USER_NAME & "&domain=" & DOMAIN_NAME & _
	"&password=" & PASSWORD & "&updatehost=1"
  countdown = TIMEOUT
  Do While objIE.Busy Or objIE.readystate <> 4
    WScript.Sleep 1000
    countdown = countdown - 1
    If countdown <= 0 Then Exit Do
  Loop
  If countdown <= 0 Then
    WshShell.LogEvent evError, "Update Timeout " & PrevText & " => " & CurText
  ElseIf InStr(objIE.Document.body.innerText, CurText) > 0 Then
    WshShell.LogEvent evInfo, "Update " & PrevText & " => " & CurText & _
	" Message:" & objIE.Document.body.innerText
    Set objWrite = FSO.OpenTextFile( PREV_FILE, ForWriting, True )
    objWrite.Write CurText
    objWrite.Close
  Else
    WshShell.LogEvent evError, "Update Failed " & PrevText & " => " & CurText & _
	" Message:" & objIE.Document.body.innerText
  End If
Else
  WshShell.LogEvent evInfo, "Same IP " & CurText
End If
objIE.Quit
Set objIE = Nothing
タグ: VBScript DNS

©2004-2017 UPKEN IPv4