ddns.frm

动态更新自己的IP地址,使用www.3322.org动态域名服务,请看readme.txt

VERSION 5.00
Begin VB.Form DDNS 
   Caption         =   "DDNS"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "DDNS"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
End
Attribute VB_Name = "DDNS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
DDNS.Visible = False   ''Don't show the form

Dim user As String, password As String, url As String, domain As String
Dim ErrInfo As String

On Error GoTo ErrHandle

user = GetFromINI("Sys", "User", App.Path + "\Config.INI")
password = GetFromINI("Sys", "password", App.Path + "\Config.INI")
domain = GetFromINI("Sys", "domain", App.Path + "\Config.INI")

url = "http://members.3322.org/dyndns/update?system=dyndns&hostname=" + _
domain + "&wildcard=OFF"

On Error GoTo ErrHandleXml
Set objxml = CreateObject("Msxml2.XMLHTTP")
ErrInfo = objxml.open("GET", url, False, user, password)
ErrInfo = objxml.setRequestHeader("Cache-Control", "no-cache")
ErrInfo = objxml.send()

Dim response As String
response = Trim(CStr(objxml.responsetext))
If Left(response, 4) = "good" Then
    response = "good"
ElseIf Left(response, 5) = "nochg" Then
    response = "nochg"
ElseIf Left(response, 6) = "nohost" Then
    response = "nohost"
ElseIf Left(response, 7) = "badauth" Then
    response = "badauth"
End If

Select Case response
    Case "nohost":
        WriteLog ("No found host")
    Case "good":
        WriteLog ("Update success")
    Case "nochg":
        WriteLog ("Check success, No update")
    Case "badauth":
        WriteLog ("Wrong user or passowrd")
End Select

Set objxml = Nothing

DeleteLastMonthFile

ErrHandleXml:
If Err.Number <> 0 Then
    WriteLog (CStr(Err.Number) + " " + Err.Description)
    Err.Clear
End If

ErrHandle:
If Err.Number <> 0 Then
    WriteLog (CStr(Err.Number) + " " + Err.Description)
    Err.Clear
End If
Unload DDNS
End Sub

Private Sub DeleteLastMonthFile()

On Error GoTo ErrHandle
Dim Fso As New FileSystemObject
Dim FileName As String, FolderArchive As String
FolderArchive = App.Path + "\Archive"

Dim Folder
Dim f As file
Dim YearMonth
YearMonth = CStr(Year(Now)) + CStr(Month(Now))
Set Folder = Fso.GetFolder(App.Path)

For Each f In Folder.Files
    If LCase(Right(f.Name, 3)) = "log" Then
        If Left(f.Name, Len(YearMonth)) <> YearMonth Then
            If Fso.FolderExists(FolderArchive) = False Then
                Fso.CreateFolder FolderArchive
            End If
            If Fso.FileExists(FolderArchive + "\" + f.Name) Then
                Fso.DeleteFile FolderArchive + "\" + f.Name
            End If
            If Fso.FileExists(App.Path + "\" + f.Name) Then
                Fso.MoveFile App.Path + "\" + f.Name, FolderArchive + "\" + f.Name
            End If
        End If
    End If
Next

ErrHandle:
Set Fso = Nothing
If Err.Number <> 0 Then
    WriteLog (CStr(Err.Number) + " " + Err.Description)
    Err.Clear
End If
End Sub