modupdate.bas

VB开发的自动更新程序

                    .ValueKey = "Reg " & sDestinationFile
                    .Value = "regsvr32 /s " & sDestinationFile
                    .CreateKey
                End With
            End If
            UpdateFile = eupdSUCCESSREBOOT
        Else
            UpdateFile = eupdINSUFFPRIV '------------ Failed to make registry entry
        End If
    End If
Else
    If bOS = 1 Then '--------- Win9X/ME
        sSourceFile = GetShortName(sSourceFile)
        sDestinationFile = GetShortName(sDestinationFile)
        '//Attempt to move the file
        lResult = MoveFile(sSourceFile & Chr(0), sDestinationFile & Chr(0))
        If lResult Then
            If REGREQ Then
                ShellExecute frmMain.hWnd, "open", "regsvr32.exe", "/s " & sDestinationFile, vbNullString, SW_HIDE
            End If
            UpdateFile = eupdSUCCESSCOMP
        Else
            '//Failed to move file (either it is in use or already exist)
            '..Lets try deleting the existing file first.
            lResult = DeleteFile(sDestinationFile)
            If lResult Then
                '//Success deleting existing file, now we are set
                lResult = MoveFile(sSourceFile & Chr(0), sDestinationFile & Chr(0))
                If REGREQ Then
                    ShellExecute frmMain.hWnd, "open", "regsvr32.exe", "/s " & sDestinationFile, vbNullString, SW_HIDE
                End If
                UpdateFile = eupdSUCCESSCOMP
            Else
                '//Failed to move file, probably because is has not been "locked" by
                '..a process, but it is infact in-use (MS calls it a  "memory-mapped file").
                '..When this occurs we cannot directly copy the new file over the existing
                '..one, but we can generally move or rename the existing file, then
                '..attempt to move the new file to the update location for next execution.
                lResult = MoveFile(sDestinationFile & Chr(0), sSourceFile & ".tmp" & Chr(0))
                If lResult Then
                    '//It was moved and renamed, now lets finish this non-sense
                    lResult = MoveFile(sSourceFile & Chr(0), sDestinationFile & Chr(0))
                    If REGREQ Then
                        ShellExecute frmMain.hWnd, "open", "regsvr32.exe", "/s " & sDestinationFile, vbNullString, SW_HIDE
                    End If
                    '//Setup to delete in-use file on reboot
                    Call AddToWininit(sSourceFile & ".tmp" & Chr(0))
                    UpdateFile = eupdSUCCESSCOMP
                Else
                    '//This attempt failed, so lets try again as an INUSE file
                    INUSE = True
                    GoTo Restart
                End If
            End If
        End If
    Else '--------------- NT Based bOS
        '//Attempt to move the file
        lResult = MoveFileEx(sSourceFile & Chr(0), sDestinationFile & Chr(0), MOVEFILE_REPLACE_EXISTING + MOVEFILE_COPY_ALLOWED)
        If lResult Then
            '//Success, now see if the new file needs registered
            If REGREQ Then
                ShellExecute frmMain.hWnd, "open", "regsvr32.exe", "/s " & sDestinationFile, vbNullString, SW_HIDE
            End If
            UpdateFile = eupdSUCCESSCOMP
        Else
            '//Failed to move file, probably because is has not been "locked" by
            '..a process, but it is infact in-use (MS calls it a  "memory-mapped file").
            '..When this occurs we cannot directly copy the new file over the existing
            '..one, but we can generally move or rename the existing file, then
            '..attempt to move the new file to the update location. This method
            '..always works on VB EXE's, so the next file execution will be up-to-date.
            lResult = MoveFileEx(sDestinationFile & Chr(0), sSourceFile & ".tmp" & Chr(0), MOVEFILE_REPLACE_EXISTING + MOVEFILE_COPY_ALLOWED)
            If lResult Then
                '//Moving the in-use file succeeded, now move the new file to the DestinationPath
                lResult = MoveFileEx(sSourceFile & Chr(0), sDestinationFile & Chr(0), MOVEFILE_REPLACE_EXISTING + MOVEFILE_COPY_ALLOWED)
                If REGREQ Then
                    ShellExecute frmMain.hWnd, "open", "regsvr32.exe", "/s " & sDestinationFile, vbNullString, SW_HIDE
                End If
                '//Setup registry to delete in-use file and temp folder on reboot. If the user is not
                '..an Admin the file will be left behind. BUT, we did coherse the update to succeed
                '..and if the user is an Admin we will also be able to clean up our mess.
                If bADMIN Then
                    '//Delete file
                    MoveFileEx sSourceFile & ".tmp" & Chr(0), vbNullString, MOVEFILE_DELAY_UNTIL_REBOOT
                    '//Delete temp directory
                    MoveFileEx Left$(sSourceFile, InStrRev(sSourceFile, "\", -1, vbTextCompare) - 1) & Chr(0), vbNullString, MOVEFILE_DELAY_UNTIL_REBOOT
                End If
                UpdateFile = eupdSUCCESSCOMP
            Else
                '//This attempt failed, so lets try again as an INUSE file
                INUSE = True
                GoTo Restart
            End If
        End If
    End If
End If

Errs_Exit:
    Exit Function

Errs:
    UpdateFile = eupdUNKNOWNERR
    Resume Errs_Exit

End Function

Public Function IsLocalPathValid(ByVal sPath As String, _
    Optional ByVal VerifyDriveExist As Boolean = False) As Boolean
'---------------------------------------------------------------------
' Purpose   : Checks if sPath will pass Windows file and folder naming
'             convention rules.
'---------------------------------------------------------------------
On Error GoTo Errs
Dim sFolders()  As String
Dim sBadChars() As String
Dim sResWords() As String
Dim sDrive      As String
Dim x           As Byte
Dim y           As Byte
    '//Exit if \\ is anywhere in path (UNC Paths NOT Supported)
    If InStr(1, sPath, "\\", vbTextCompare) Then Exit Function
    '//Fill invalid character and reserved word arrays
    sBadChars = Split("\ / : * ? < > | " & Chr(34), " ")
    sResWords = Split("COM1 COM2 COM3 COM4 COM5 COM6 COM7 COM8 COM9 LPT1 LPT2 LPT3 LPT4 LPT5 LPT6 LPT7 " & _
                        "LPT8 LPT9 AUX CLOCK$ CON NUL PRN", " ")
    sFolders = Split(sPath, "\") '------------- Fill array with drive and folders
    sDrive = LCase$(sFolders(0)) '-------------- Extract drive and check if valid
    If VerifyDriveExist Then
        If Dir$(sDrive, 63) = "" Then Exit Function
    Else
        For x = 97 To 122 '-------------------- Check to ensure drive letter is a - z
            If sDrive = Chr(x) & ":" Then Exit For
        Next x
        If x = 123 Then Exit Function '-------- Drive letter was not a through z
    End If
    
    For y = 1 To UBound(sFolders)
        For x = 0 To 7 '----------------------- Check for invalid folder characters
            If InStr(1, sFolders(y), sBadChars(x)) Then Exit Function
        Next x
        For x = 0 To 22 '---------------------- Check for reserved words
            If UCase$(sFolders(y)) = sResWords(x) Then Exit Function
        Next x
    Next y
    IsLocalPathValid = True
Errs:
    If Err Then Exit Function
End Function

Public Function GetFileExt(ByVal sFile As String) As String
'---------------------------------------------------------
' Purpose   : Returns a files file extension if one exist.
'---------------------------------------------------------
On Error GoTo Errs
Dim x   As Long
Dim y   As Long
    x = InStrRev(sFile, ".")
    If x Then '---------------------- Skip if a "." is not found
        y = InStrRev(sFile, "\")
        If y Then
            If y < x Then '---------- Be sure "." is to the right of last "\"
                GetFileExt = UCase$(Mid$(sFile, x + 1))
            End If
        Else '----------------------- For passing only a filename without a path
            GetFileExt = UCase$(Mid$(sFile, x + 1))
        End If
    End If
Errs:
    If Err Then GetFileExt = ""
End Function

Public Function WindowsVersion() As Long
'--------------------------------------------------------------
' Purpose   : Returns 1 if 95/98/ME and 2 or > for NT based OS.
'--------------------------------------------------------------
Dim osinfo   As OSVERSIONINFO
Dim retvalue As Integer
    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    retvalue = GetVersionExA(osinfo)
    WindowsVersion = osinfo.dwPlatformId
End Function

Public Function CanWriteToPath(ByVal sPath As String) As Boolean
'-------------------------------------------------------------------
' Purpose   : Checks for write permission to a given path. sPath must
'             exist to return True. Supports local and UNC paths.
'--------------------------------------------------------------------
On Error GoTo Errs
Dim f  As Integer
    If Len(sPath) < 2 Then Exit Function
    If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
    sPath = sPath & "WriteCheck.tmp" '------------------- Create temp file
    f = FreeFile
    Open sPath For Output As #f '------------------------ Attempt write
        Print #f, "Test"
    Close #f
    CanWriteToPath = True
    On Error Resume Next
    Call DeleteFile(sPath) '----------------------------- Delete temp file
Errs:
    If Err Then Exit Function
End Function

Public Function IsAdministrator() As Boolean
'*******************************************************************************************
'Adapted from code written by Randy Birch, http://vbnet.mvps.org
'"How to Determine if the Current User is a Member of Administrators"
'Full post is here: http://vbnet.mvps.org/index.html?code/network/isadministrator.htm
'*******************************************************************************************
 Dim hProcessID     As Long
 Dim hToken         As Long
 Dim res            As Long
 Dim cbBuff         As Long
 Dim tiLen          As Long
 Dim TG             As TOKEN_GROUPS
 Dim SIA            As SID_IDENTIFIER_AUTHORITY
 Dim lSid           As Long
 Dim cnt            As Long
 Dim sAcctName1     As String
 Dim sAcctName2     As String
 Dim cbAcctName     As Long
 Dim sDomainName    As String
 Dim cbDomainName   As Long
 Dim peUse          As Long
    '//See if OS is Win9X or ME.
    '..This is the only thing I edited in this routine.
    If bOS = 1 Then
        IsAdministrator = True
        Exit Function
    End If
    tiLen = 0
    'obtain handle to process. 0 indicates failure;
    'may return -1 for current process (and is valid)
    hProcessID = GetCurrentProcess()
    If hProcessID <> 0 Then
        'obtain a handle to the access
        'token associated with the process
        If OpenProcessToken(hProcessID, TOKEN_READ, hToken) = 1 Then
            'retrieve specified information
            'about an access token. The first