modupdate.bas

VB开发的自动更新程序

Attribute VB_Name = "modUpdate"
'***********************************************************************
'
'Chris Cochran          [e-mail]        Updated: 18 Aug 05
'
'THIS MODULE IS WRITTEN FOR THE SOLE PURPOSE OF SYSTEMATICALLY REPLACING
'OR INSTALLING FILES FOR PERFORMING APPLICATION UPDATES OR INSTALLS. ALL
'OF THE BELOW ROUTINES ARE WINDOWS 95 THROUGH XP COMPATIBLE.
'
'MODULE MUST ACCOMPANY cREG CLASS (Written by Steve McMahon). ALL OTHER
'FUNCTIONS IN THIS MODULE ARE INDEPENDENT OF ALL OTHER CODE IN THIS
'PROJECT. THIS WAS DONE FOR REUSABILITY. THE GetFileExt, WindowsVersion,
'IsAdministrator, IsLocalPathValid, and WindowsVersion FUNCTIONS ARE
'MADE PUBLIC HERE TO ELIMINATE SOME REDUNDANCY IN THIS PROJECT.
'***********************************************************************

Option Explicit

'//Returns from Update routine
Public Enum eupdResults
    eupdSUCCESSCOMP = 0 '-------- Success/Complete
    eupdSUCCESSREBOOT = 1 '------ Success/Reboot required
    eupdSOURCENOTFOUND = 2 '----- Source file not found
    eupdDESTINVALID = 3 '-------- Destination path invalid
    eupdINSUFFPRIV = 4 '--------- Insufficient privilege
    eupdUNKNOWNERR = 5 '--------- Unknown update error
End Enum

'//Establishes Windows directory. A must have for Win9X/ME when manipulating wininit.ini
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'//WindowsVersion Declarations
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Private Type OSVERSIONINFO
    dwOSVersionInfoSize                     As Long
    dwMajorVersion                          As Long
    dwMinorVersion                          As Long
    dwBuildNumber                           As Long
    dwPlatformId                            As Long '1 = Windows 95/98. '2 = Windows NT and Up
    szCSDVersion                            As String * 128
End Type

'//DECLARES For FileInUse
Private Const OFS_MAXPATHNAME               As Long = 128
Private Const OF_SHARE_EXCLUSIVE            As Long = &H10
Private Type OFSTRUCT
    cBytes                                  As Byte
    fFixedDisk                              As Byte
    nErrCode                                As Integer
    Reserved1                               As Integer
    Reserved2                               As Integer
    szPathName(OFS_MAXPATHNAME)             As Byte
End Type
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, ByRef lpReOpenBuff As OFSTRUCT, ByVal uStyle As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long

'//MoveFile/DeleteFile Declares
Private Const MOVEFILE_REPLACE_EXISTING     As Long = &H1
Private Const MOVEFILE_DELAY_UNTIL_REBOOT   As Long = &H4
Private Const MOVEFILE_COPY_ALLOWED         As Long = &H2
Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long


'//IsAdministrator Declares
Private Const TOKEN_READ                    As Long = &H20008
Private Const SECURITY_BUILTIN_DOMAIN_RID   As Long = &H20&
Private Const DOMAIN_ALIAS_RID_ADMINS       As Long = &H220&
Private Const SECURITY_NT_AUTHORITY         As Long = &H5
Private Const TokenGroups                   As Long = 2
Private Type SID_IDENTIFIER_AUTHORITY
    Value(6)                                As Byte
End Type
Private Type SID_AND_ATTRIBUTES
    Sid                                     As Long
    Attributes                              As Long
End Type
Private Type TOKEN_GROUPS
    GroupCount                              As Long
    Groups(500)                             As SID_AND_ATTRIBUTES
End Type
Private Declare Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As Long, ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function AllocateAndInitializeSid Lib "advapi32.dll" (pIdentifierAuthority As SID_IDENTIFIER_AUTHORITY, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal TokenInformationClass As Long, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Sub FreeSid Lib "advapi32.dll" (pSid As Any)

'//For Win 9X/ME (wininit.ini only processes short file name paths)
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Public Function TestUpdateSuccess(ByVal sSourceFile As String, _
    ByVal sDestinationFile As String) As eupdResults
'--------------------------------------------------------------------------------------
' Purpose   : This routine evaluates if the update operation can complete without error
'             prior to attempting UpdateFile operation. This is used for validating a
'             group of files will succeed before committing an update to any one file.
'
' Checks For:
'       - A valid source file
'       - Valid destination path meeting Windows naming conventions
'       - The ability to create destination path
'       - Admin privilege when in-use files must be processed after reboot
'       - Admin privilege for DLL/OCX files that require regsvr32
'       - Write permission to the destination path
'
' VerifySuccess Returns:
'       0 = Success/Complete
'       2 = sSourceFile not found
'       3 = Destination invalid/Destination write error
'       4 = Insufficient privilege
'--------------------------------------------------------------------------------------
On Error GoTo Errs

Dim INUSE   As Boolean  '--- File In-Use status
Dim FILEEXT As String   '--- File extension of sDestinationFile
Dim path    As String   '--- Update files destination path
    INUSE = FileInUse(sDestinationFile)
    FILEEXT = GetFileExt(sDestinationFile)
    path = Left$(sDestinationFile, InStrRev(sDestinationFile, "\", , vbTextCompare))
    'Ensure source file is downloaded and available
    If Dir$(sSourceFile, vbArchive + vbHidden + vbNormal + vbReadOnly + vbSystem) = "" Then
        TestUpdateSuccess = eupdSOURCENOTFOUND
    'See if file is in use and if user has the rights to update those that are
    ElseIf INUSE And Not bADMIN Then
        TestUpdateSuccess = eupdINSUFFPRIV
    'See if user can register OCX and DLL files when required
    ElseIf (FILEEXT = "OCX" Or FILEEXT = "DLL") And Not bADMIN Then
        TestUpdateSuccess = eupdINSUFFPRIV
    'Verify install path meets Windows naming conventions and can be created
    ElseIf Not CreatePath(path) Then
        TestUpdateSuccess = eupdDESTINVALID
    'Verify user has write access in install path
    ElseIf Not CanWriteToPath(path) Then
        TestUpdateSuccess = eupdINSUFFPRIV
    Else
        TestUpdateSuccess = eupdSUCCESSCOMP
    End If
Errs_Exit:
    Exit Function
Errs:
    TestUpdateSuccess = eupdUNKNOWNERR
    Resume Errs_Exit
End Function

Public Function UpdateFile(ByVal sSourceFile As String, ByVal sDestinationFile As String) As eupdResults
'--------------------------------------------------------------------------------------
' Purpose   : This routine evaluates and executes a strategy for updating or installing
'             the passed sDestinationFile with the passed sSourceFile.
'
' Returns   : 0 = Success/Complete
'             1 = Success/Reboot Required
'             2 = sSourceFile not found
'             3 = Destination invalid/Destination write error
'             4 = Insufficient privilege
'             5 = Unknown Error
'
' IMPORTANT : 1. sDestinationFile names should be in DOS 8.3 format for Windows 95/98
'                and ME compatibility. (See Included README.rtf)
'             2. UNC paths for sDestinationFile are not supported. (i.e. "\\LANComp")
'
' REFERENCE : "How To Move Files That Are Currently in Use", Microsoft
'             http://support.microsoft.com/default.aspx?scid=kb;EN-US;140570
'--------------------------------------------------------------------------------------
On Error GoTo Errs
Dim INUSE       As Boolean      'Preliminary file In-Use status
Dim REGREQ      As Boolean      'File will require registerin with regsvr32
Dim EXT         As String       'Destination files extension
Dim lResult     As Long
Dim c           As New cReg

'--- WHERE WE ARE NOW? SO FAR WE HAVE DONE THE FOLLOWING (FROM SUB TESTUPDATESUCCESS):
'       - Ensured source file is valid
'       - Validated destination path met Windows naming conventions
'       - Successfully created the destination path
'       - Verified Admin privilege for in-use files that must be processed after reboot
'       - Verified Admin privilege for DLL & OCX files that require regsvr32
'       - Verified we have write permission to the destination path
'--- NOW LETS GET FREAKY...

EXT = GetFileExt(sDestinationFile)
INUSE = FileInUse(sDestinationFile)
REGREQ = IIf(EXT = "OCX" Or EXT = "DLL", True, False)

'******************************************************************************************
'***   NOTE: THE FOLLOWING MUST BE AS BULLETPROOF AS OUR COLLECTIVE MINDS CAN MAKE IT   ***
'*** I WELCOME ALL SUGGESTIONS, PLEASE ADVISE WITH IMPROVEMENTS. [e-mail] ***
'******************************************************************************************

Restart:
If INUSE Then
    If bOS = 1 Then '------- Win9X/ME
        sSourceFile = GetShortName(sSourceFile)
        '//Once again verify sourcefile is valid once converted to a short path
        If Dir$(sSourceFile, vbArchive + vbHidden + vbNormal + vbReadOnly + vbSystem) = "" Then
            UpdateFile = eupdSOURCENOTFOUND
            Exit Function
        End If
        sDestinationFile = GetShortName(sDestinationFile)
        '//Once again verify destinationfile path exist once converted to a short path
        If Dir$(Left$(sDestinationFile, InStrRev(sDestinationFile, "\", , vbTextCompare)), vbDirectory) = "" Then
            UpdateFile = eupdDESTINVALID
            Exit Function
        End If
        '//First setup Wininit to delete current out-of-date file on reboot
        If AddToWininit(sDestinationFile) Then
            '//Now setup Wininit to move up-to-date file to DestinationPath on reboot
            If AddToWininit(sSourceFile, sDestinationFile) Then
                '//Setup Registry to register up-to-date file on reboot once it is moved
                If REGREQ Then
                    With c
                        .ClassKey = HKEY_LOCAL_MACHINE
                        .SectionKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce"
                        .ValueType = REG_SZ
                        .ValueKey = "Reg " & sDestinationFile
                        .Value = "regsvr32 /s " & sDestinationFile
                        .CreateKey
                    End With
                End If
                UpdateFile = eupdSUCCESSREBOOT
            Else
                UpdateFile = eupdUNKNOWNERR
            End If
        Else
            UpdateFile = eupdUNKNOWNERR
        End If
    Else '------------------ Win NT based
        '//User MUST be an Admin on NT based bOS's for INUSE files in all scenarios. We check this first.
        If Not bADMIN Then UpdateFile = eupdINSUFFPRIV: Exit Function
        '//Make registry entry to move file after reboot
        lResult = MoveFileEx(sSourceFile & Chr(0), sDestinationFile & Chr(0), MOVEFILE_DELAY_UNTIL_REBOOT + MOVEFILE_REPLACE_EXISTING)
        If lResult Then
            '//Make registry entry to delete temp directory after reboot
            lResult = MoveFileEx(Left$(sSourceFile, InStrRev(sSourceFile, "\", -1, vbTextCompare) - 1) & Chr(0), vbNullString, MOVEFILE_DELAY_UNTIL_REBOOT)
            '//Make registry entry to register new file after reboot once it is moved
            If REGREQ Then
                With c
                    .ClassKey = HKEY_LOCAL_MACHINE
                    .SectionKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce"
                    .ValueType = REG_SZ