modscript.bas

VB开发的自动更新程序

Attribute VB_Name = "modScript"
'***********************************************************************
'Chris Cochran          [e-mail]        Updated: 18 Oct 05
'***********************************************************************
Option Explicit

'//Status of update file progress
Public Enum eStatus
    NOUPDATEREQ = 0                     '//Update not required
    UPDATEREQ = 1                       '//Update required
    DOWNLOADING = 2                     '//Currently downloading
    DOWNLOADED = 3                      '//Finished download
    ERRCONNECTING = 4                   '//Could not connect to host or file
    ERRTRANSFERRING = 5                 '//Transfer started but failed
    INSUFFPRIVILEGE = 6                 '//User must be an admin and is not
    ERRUPDATING = 7                     '//TestUpdateSuccess or UpdateFile returned non-zero value
    UPDATECOMP = 8                      '//Update complete
    UPDATECOMPREBOOT = 9                '//Update complete, reboot required
    UPDATEREADY = 10                    '//TestUpdateSuccess successful, ready for update
    FILENOTINSTALLED = 11               '//Will not be transferred, script has MustBeInstalled=1 and file is not
End Enum

'//Run mode enumerators
Public Enum eRunMode
    eNORMAL = 0
    eNOTIFY = 1
    eAUTO = 2
End Enum

'//Update file list array (Most variables are filled in ParseUpdateScript routine)
Public Type tFileList
    Description()           As String   '//Short File Description
    UpdateVersion()         As String   '//Update File Version
    CurrentVersion()        As String   '//Installed File Version
    DownloadURL()           As String   '//Web download path (URL)
    FileSize()              As Long     '//Size of download (To show total download progress)
    InstallPath()           As String   '//Location of client file to update (Use directory constants, i.e. {APPPATH}\MyProg.exe = App.Path & "\MyProg.exe" on client
    FileName()              As String   '//Filename of update file
    TempPath()              As String   '//Temporary storage path for downloaded while waiting processing
    MustExist()             As Boolean  '//File must exist on users machine to be transferred
    MustUpdate()            As Boolean  '//1 if file must update if required to continue LiveUpdate
    UpdateMessage()         As String   '//String displayed when ReVive exits if file is updated on client
    Status()                As eStatus  '//Progress state of file from eStatus Enumerator
End Type

'***START DECLARES FOR GetFileVersion***
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwhandle As Long, ByVal dwlen As Long, lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Byte, ByVal lpSubBlock As String, lplpBuffer As Long, puLen As Long) As Long
Private Type VS_FIXEDFILEINFO
    dwSignature             As Long
    dwStrucVersion          As Long
    dwFileVersionMS         As Long
    dwFileVersionLS         As Long
    dwProductVersionMS      As Long
    dwProductVersionLS      As Long
    dwFileFlagsMask         As Long
    dwFileFlags             As Long
    dwFileOS                As Long
    dwFileType              As Long
    dwFileSubtype           As Long
    dwFileDateMS            As Long
    dwFileDateLS            As Long
End Type
'***END DECLARES FOR GetFileVersion***

'//Directory constants available for use in web update script.
'//Want to add more? See ReplaceConstants routine below.
'//CAUTION: BE SURE ADDITIONS ARE WINDOWS VERSION FRIENDLY OR
'//IMPLEMENT A PLAN B (LIKE IIf) TO DEFAULT TO A COMMON VALUE.
Private ap                  As String   '//App.Path from where this exe is executed
Private sp                   As String   '//Path of setup script from arguments in Sub Main (App.Path if script not specific)
Private win                 As String   '//Windows directory (Like C:\Winnt)
Private sys                 As String   '//System directory (Like C:\Winnt\System32)
Private temp                As String   '//Windows Temp directory (Like C:\Winnt\Temp)
Private pf                  As String   '//Program files directory (Like C:\Program Files)
Private cf                  As String   '//Common files path (Like C:\Program Files\Common Files)
Private userdesktop         As String   '//Current users desktop
Private userstartmenu       As String   '//Current users start menu
Private commondesktop       As String   '//All users Desktop directory (Like C:\Documents and Settings\All Users\Desktop)
Private commonstartmenu     As String   '//All users start menu

'//LiveUpdate Settings declares
Public Type tSetup
    SetupScriptPath         As String
    AppShortName            As String
    AppLongName             As String
    AdminRequired           As Boolean
    ForceReboots            As Boolean
    ScriptURLPrim           As String
    ScriptURLAlt            As String
    LastChecked             As String
    RunMode                 As eRunMode
    NotifyIcon              As String
    UpdateAppTitle          As String
    UpdateAppClass          As String
    UpdateAppKill           As Boolean
    LaunchIfKilled          As String
    ShowFileIcons           As Boolean
    RegRISFiles             As Boolean
    HideAbsentFiles         As Boolean
End Type

Public FileList             As tFileList    '//Makes update file list available to entire app
Public Setup                As tSetup       '//Stored LiveUpdate settings for active script
Public bREBOOT              As Boolean      '//Set to True when any update file requires a reboot to update (regsvr32)

Public Function ParseUpdateScript(ByVal sFile As String) As Byte
'------------------------------------------------------------------------
' Purpose   : Opens downloaded update file, reads and parses update list,
'             and fills FileList array with update file list entries.
'             This routine also ensures script info is valid, admin
'             priviledge exist when required, and MustExist files are
'             present on users computer. All this before downloads begin.
'
' Returns   : 0 if success
'             1 if client must be an Administrator to continue and is not
'             2 if an error was encountered processing script
'             3 if there are no updates listed in the update script
'------------------------------------------------------------------------
On Error GoTo Errs
Dim f           As Integer '--- Freefile assignment
Dim s           As String '---- Misc string uses
Dim x           As Long '------ Misc long uses
Dim y           As Long
Dim sEXT        As String '---- File extension
Dim reg         As Boolean '--- True if any update files are OCX or DLL
Dim sec         As String '---- Current [File XX] section we are searching in

    If Dir$(sFile, vbNormal + vbReadOnly + vbArchive + vbHidden + vbSystem) = "" Then
        ParseUpdateScript = 2 '--- sFile not found, return script error
        Exit Function
    End If
    f = FreeFile
    Open sFile For Input As #f '-- Open sFile for parsing setup information
    Call AssignContants '--------- Assign script contants to client folders
    With Setup '------------------ Get Script Setup settings
        .AdminRequired = CBool(ProfileGetItem("SETUP", "AdminRequired", 0, sFile))
        .ForceReboots = CBool(ProfileGetItem("SETUP", "ForceReboots", 0, sFile))
        .ScriptURLPrim = ProfileGetItem("SETUP", "ScriptURLPrim", frmMain.ucDL.dScriptURLPrim, sFile)
        .ScriptURLAlt = ProfileGetItem("SETUP", "ScriptURLAlt", frmMain.ucDL.dScriptURLAlt, sFile)
        .AppShortName = ProfileGetItem("SETUP", "AppShortName", frmMain.ucDL.dAppShortName, sFile)
        .AppLongName = ProfileGetItem("SETUP", "AppLongName", frmMain.ucDL.dAppLongName, sFile)
        .NotifyIcon = ProfileGetItem("SETUP", "NotifyIcon", "", sFile)
        .UpdateAppTitle = ProfileGetItem("SETUP", "UpdateAppTitle", "", sFile)
        .UpdateAppClass = ProfileGetItem("SETUP", "UpdateAppClass", "", sFile)
        .UpdateAppKill = ProfileGetItem("SETUP", "UpdateAppKill", False, sFile)
        .LaunchIfKilled = ReplaceConstants(ProfileGetItem("SETUP", "LaunchIfKilled", "", sFile))
        .ShowFileIcons = ProfileGetItem("SETUP", "ShowFileIcons", True, sFile)
        .RegRISFiles = ProfileGetItem("SETUP", "RegRISFiles", False, sFile)
        .HideAbsentFiles = ProfileGetItem("SETUP", "HideAbsentFiles", False, sFile)
        .HideAbsentFiles = True
    End With
    With FileList '--------------- Locate all update file entries in script
        Do
            x = x + 1
            sec = "File " & Format(x, "00")
            s = ProfileGetItem(sec, "Description", "", sFile)
            If Len(s) Then
                ReDim Preserve .Description(1 To x)
                ReDim Preserve .UpdateVersion(1 To x)
                ReDim Preserve .CurrentVersion(1 To x)
                ReDim Preserve .DownloadURL(1 To x)
                ReDim Preserve .InstallPath(1 To x)
                ReDim Preserve .FileName(1 To x)
                ReDim Preserve .TempPath(1 To x)
                ReDim Preserve .MustExist(1 To x)
                ReDim Preserve .FileSize(1 To x)
                ReDim Preserve .MustUpdate(1 To x)
                ReDim Preserve .UpdateMessage(1 To x)
                ReDim Preserve .Status(1 To x)
                .Description(x) = s
                .UpdateVersion(x) = ProfileGetItem(sec, "UpdateVersion", "0.0.0.0", sFile)
                .DownloadURL(x) = ProfileGetItem(sec, "DownloadURL", "", sFile)
                .InstallPath(x) = ReplaceConstants(ProfileGetItem(sec, "InstallPath", "", sFile))
                .FileName(x) = Right$(.InstallPath(x), Len(.InstallPath(x)) - InStrRev(.InstallPath(x), "\"))
                .FileSize(x) = ProfileGetItem(sec, "FileSize", 0, sFile)
                .MustExist(x) = CBool(ProfileGetItem(sec, "MustExist", False, sFile))
                .MustUpdate(x) = CBool(ProfileGetItem(sec, "MustUpdate", False, sFile))
                .UpdateMessage(x) = Trim$(ProfileGetItem(sec, "UpdateMessage", "", sFile))
                .TempPath(x) = sTEMPDIR & "\" & GetFileName(.InstallPath(x))
                sEXT = GetFileExt(.InstallPath(x))
                '//Check for files that must be registered using Regsvr32
                If sEXT = "OCX" Or sEXT = "DLL" Then
                    reg = True
                End If
                '******************** START PRELIMINARY SCRIPT INFO VALIDATION ***********************
                '//Values not validated below are good because they met data type criteria above
                '..or will be validated later when testing update success before updating.
                
                '//Validate that supplied version number is valid
                If IsVersionValid(.UpdateVersion(x)) = 0 Then
                    ParseUpdateScript = 2 '------------- Return script error, invalid version number
                    Exit Do
                End If
                '//Verify InstallPath is valid when MustUpdate = True
                If .MustUpdate(x) Then
                    If Not IsLocalPathValid(.InstallPath(x), True) Then
                        ParseUpdateScript = 2 '--------- Return script error, install path invalid
                        Exit Do
                    End If
                End If
                '//Verify file exist on clients machine when MustBeInstalled = True
                If .MustExist(x) Or (.MustExist(x) And Setup.HideAbsentFiles) Then
                    If Dir$(.InstallPath(x), 39) = "" Then
                        '//Not found and required. This will cause an abort in frmMain's ListScanResults
                        '..routine if file is flagged as MustUpdate.
                        .Status(x) = FILENOTINSTALLED
                    End If
                End If
                '******************** END PRELIMINARY SCRIPT INFO VALIDATION *************************
            Else
                Exit Do
            End If
        Loop
        Close #f '-------------------------------- Close downloaded web update script
    End With
    If x = 1 And ParseUpdateScript = 0 Then '----- No update files found in script
        ParseUpdateScript = 3
    End If
    If ParseUpdateScript = 0 Then
        '//Prepare listview for vertical scrollbar if file count exceeds visible capability
        y = IIf(Setup.ShowFileIcons, 11, 13)
        If x > y Then frmMain.lvFiles.ColumnHeaders(1).Width = 3000
        '//Check for sufficient privilege
        If Setup.AdminRequired Or reg Then '----- Check both script flag and DLL/OCX registration requirements
            If Not bADMIN Then '----------------- Check if client is an Administrator
                ParseUpdateScript = 1 '---------- Return permission insufficient
                GoTo Errs_Exit '----------------- Be done with this nonsense - the users a peon
            End If
        End If
        If bADMIN And Setup.RegRISFiles Then '--- Register .ris files to open with ReVive
            Call RegRISFile
        End If
        Call CompareFileVersions '--------------- Script read fine and all files passed above tests
    End If