modscript.bas

VB开发的自动更新程序

Errs_Exit:
    On Error Resume Next
    Call DeleteFile(sFile) '--------------------- Delete downloaded script file
    Exit Function
Errs:
    ParseUpdateScript = 2 '---------------------- Return script error
    Resume Errs_Exit
End Function

'****************************************************************************************
'                               Private Helper Functions
'****************************************************************************************

Private Sub AssignContants()
'------------------------------------------------------------------------
' Purpose   : Assigns local folders to available update script constants.
'------------------------------------------------------------------------
On Error Resume Next
    ap = App.path
    '//Remove right most '\' if ap is located on a root drive
    If Right$(ap, 1) = "\" Then ap = Left$(ap, InStrRev(ap, "\") - 1)
    sp = Left$(Setup.SetupScriptPath, InStrRev(Setup.SetupScriptPath, "\") - 1)
    win = GetFolderPath(CSIDL_WINDOWS)
    sys = GetFolderPath(CSIDL_SYSTEM)
    temp = win & "\Temp"
    pf = GetFolderPath(CSIDL_PROGRAM_FILES)
    cf = GetFolderPath(CSIDL_PROGRAM_FILES_COMMON)
    userdesktop = GetFolderPath(CSIDL_DESKTOPDIRECTORY)
    commondesktop = IIf(Len(GetFolderPath(CSIDL_COMMON_DESKTOPDIRECTORY)) = 0, userdesktop, GetFolderPath(CSIDL_COMMON_DESKTOPDIRECTORY))
    userstartmenu = GetFolderPath(CSIDL_STARTMENU)
    commonstartmenu = IIf(Len(GetFolderPath(CSIDL_COMMON_STARTMENU)) = 0, userstartmenu, GetFolderPath(CSIDL_COMMON_STARTMENU))
End Sub

Private Function ReplaceConstants(ByVal sString As String) As String
'*******************************************************************
'Called from ParseUpdateScript routine for InstallPath contants.
'
'If an unrecognized constant was used, an empty string is returned,
'which will cause a script error in ParseUpdateScript routine.
'
'WANT TO ADD MORE? (Checkout modFolders for more possibilites)
'   Step 1: Update list in declaration section of this module.
'   Step 2: Add to AssignContants sub above and assign a value.
'   Step 3: Insert an InStr for each addition in this procedure.
'*******************************************************************
    '//Verify a constant was used before continuing
    If InStr(1, sString, "<", vbTextCompare) = 0 And _
            InStr(1, sString, ">", vbTextCompare) = 0 Then
        ReplaceConstants = sString
        Exit Function
    End If
    '-------------ONLY ONE CONSTANT PER PATH PROCESSED--------------
    '-----------MOST COMMONLY USED AT TOP FOR EFFICIENCY------------
    If InStr(1, sString, "<sp>", vbTextCompare) Then
        sString = Replace(sString, "<sp>", sp)
    ElseIf InStr(1, sString, "<ap>", vbTextCompare) Then
        sString = Replace(sString, "<ap>", ap)
    ElseIf InStr(1, sString, "<sys>", vbTextCompare) Then
        sString = Replace(sString, "<sys>", sys)
    ElseIf InStr(1, sString, "<win>", vbTextCompare) Then
        sString = Replace(sString, "<win>", win)
    ElseIf InStr(1, sString, "<temp>", vbTextCompare) Then
        sString = Replace(sString, "<temp>", temp)
    ElseIf InStr(1, sString, "<userdesktop>", vbTextCompare) Then
        sString = Replace(sString, "<userdesktop>", userdesktop)
    ElseIf InStr(1, sString, "<userstartmenu>", vbTextCompare) Then
        sString = Replace(sString, "<userstartmenu>", userstartmenu)
    ElseIf InStr(1, sString, "<pf>", vbTextCompare) Then
        sString = Replace(sString, "<pf>", pf)
    ElseIf InStr(1, sString, "<cf>", vbTextCompare) Then
        sString = Replace(sString, "<cf>", cf)
    Else
        '//An unrecognized constant was used (will be caught by ParseUpdateScript)
        Exit Function
    End If
    '//Verify no more than one constant was used
    If InStr(1, sString, "<", vbTextCompare) Or _
            InStr(1, sString, ">", vbTextCompare) Then
        sString = ""
    End If
    ReplaceConstants = sString
End Function

Private Sub CompareFileVersions()
'----------------------------------------------------------------------------------
' Purpose   : Called from ParseUpdateScript routine. Determines what files from
'             the FileList array require updating by LiveUpdate.
'
'             NOTE: Existing OCX, DLL and EXE file versions are gained from the
'             file itself, while all others are extracted from the local RIS file.
'----------------------------------------------------------------------------------
Dim sNewVer()   As String
Dim sExistVer() As String
Dim i           As Byte
Dim x           As Long
Dim s           As String
    With FileList
        For x = 1 To UBound(.Description)
            '//First get the existing file version
            s = GetFileExt(.InstallPath(x))
            If InStr(1, "|EXE|OCX|DLL|", s) Then
                '//Pull version info from file
                .CurrentVersion(x) = GetFileVersion(.InstallPath(x))
                '//If file did not contain version info, check the setup script
                If .CurrentVersion(x) = "0.0.0.0" Then
                    '//First see if file exist on client before getting ver info from clients setup script
                    If Dir$(.InstallPath(x), vbArchive + vbHidden + vbNormal + vbReadOnly + vbSystem) <> "" Then
                        .CurrentVersion(x) = ProfileGetItem("Files", .Description(x), "0.0.0.0", Setup.SetupScriptPath)
                    End If
                End If
            Else
                '//First see if file exist on client before getting ver info from clients setup script
                If Dir$(.InstallPath(x), vbArchive + vbHidden + vbNormal + vbReadOnly + vbSystem) = "" Then
                    .CurrentVersion(x) = "0.0.0.0"
                Else
                    .CurrentVersion(x) = ProfileGetItem("Files", .Description(x), "0.0.0.0", Setup.SetupScriptPath)
                End If
            End If
            '//Break version numbers down to 4 different segments for comparing each one
            sNewVer() = Split(.UpdateVersion(x), ".", , vbTextCompare)
            sExistVer() = Split(.CurrentVersion(x), ".", , vbTextCompare)
            If .Status(x) <> FILENOTINSTALLED Then
                '//Compare each segment until we hit a newer version number or try all four segments
                For i = 0 To 3
                    If CLng(sNewVer(i)) > CLng(sExistVer(i)) Then
                        .Status(x) = UPDATEREQ
                        Exit For
                    End If
                Next i
            End If
        Next x
    End With
End Sub

Public Function GetFileVersion(ByVal sFileName As String) As String
'***********************************************************************
' Purpose   : Get the file version number from DLL, EXE, or OCX files.
'
' Adapted from code posted by Eric D. Burdo, http://www.rlisolutions.com
' "Retrieve the version number of a DLL"
'
' Full Post : http://programmers-corner.com/viewSource.php/71
'***********************************************************************
Dim lFreeSize   As Long
Dim tVerBuf()   As Byte
Dim sVerInfo    As VS_FIXEDFILEINFO
Dim lFreeHandle As Long
Dim lBuff       As Long
Dim iMajor      As Integer
Dim iMinor      As Integer
Dim sMajor      As String
Dim sMinor      As String
    lFreeSize = GetFileVersionInfoSize(sFileName, lFreeHandle)
    If lFreeSize Then
        If lFreeSize > 64000 Then lFreeSize = 64000
        ReDim tVerBuf(lFreeSize)
        GetFileVersionInfo sFileName, 0&, lFreeSize, tVerBuf(0)
        VerQueryValue tVerBuf(0), "\" & "", lBuff, lFreeSize
        CopyMem sVerInfo, ByVal lBuff, lFreeSize
    End If
    iMajor = CInt(sVerInfo.dwFileVersionMS \ &H10000)
    iMinor = CInt(sVerInfo.dwFileVersionMS And &HFFFF&)
    sMajor = CStr(iMajor) & "." & LTrim$(CStr(iMinor))
    iMajor = CInt(sVerInfo.dwFileVersionLS \ &H10000)
    iMinor = CInt(sVerInfo.dwFileVersionLS And &HFFFF&)
    sMinor = CStr(iMajor) & "." & LTrim$(CStr(iMinor))
    GetFileVersion = sMajor & "." & sMinor
End Function

Private Function IsVersionValid(ByVal sVersion As String) As Boolean
'--------------------------------------------------------------------------
' Purpose:  Verifies version number meets format '0.0.0.0'. Only numbers
'           0 - 9 can be used in each version number segment, and there
'           must be 4 version number segments, like '10.0.3.99'.
'--------------------------------------------------------------------------
On Error GoTo Errs
Dim sVer()  As String
Dim i       As Byte
Dim x       As Byte
    sVer() = Split(sVersion, ".", , vbTextCompare)
    If UBound(sVer) = 3 Then '------------------------------- Verify exactly 4 segments exist
        For i = 0 To 3
            If Len(sVer(i)) = 0 Then Exit Function '--------- Verify segment is not 0 length
            For x = 1 To Len(sVer(i)) '---------------------- Verify each segment character is numeric
                If Not IsNumeric(Mid$(sVer(i), x, 1)) Then Exit Function
            Next x
        Next i
        IsVersionValid = True
    End If
Errs:
    Exit Function
End Function

Private Function GetFileName(ByVal sFilePath As String) As String
'--------------------------------------------------
' Purpose   : Returns filename from sFilePath path
'--------------------------------------------------
On Error GoTo Errs
Dim x As Long
    x = InStrRev(sFilePath, "\")
    If x Then sFilePath = Mid$(sFilePath, x + 1)
    GetFileName = sFilePath
Errs:
    If Err Then GetFileName = ""
End Function

Private Sub RegRISFile()
'--------------------------------------------------------------------
' Purpose   : Registers .ris files to open with the ReVive executable
'--------------------------------------------------------------------
On Error GoTo Errs
Dim c       As New cReg
    If Dir(App.path & "\" & App.EXEName & ".exe", 39) = "" Then Exit Sub
    With c
        .ClassKey = HKEY_CLASSES_ROOT
        .SectionKey = ".ris"
        .ValueType = REG_SZ
        .ValueKey = ""
        .Value = "ReVive.Initialization.Script"
        .CreateKey
        .SectionKey = "ReVive.Initialization.Script"
        .ValueKey = ""
        .Value = "ReVive LiveUpdate Initialization Script"
        .CreateKey
        .SectionKey = "ReVive.Initialization.Script\shell\open\command"
        .ValueKey = ""
        .Value = Chr(34) & App.path & "\" & App.EXEName & ".exe" & Chr(34) & " " & Chr(34) & "%1" & Chr(34)
        .CreateKey
    End With
Errs_Exit:
    Set c = Nothing
    Exit Sub
Errs:
    Resume Errs_Exit
End Sub