modglobal.bas

VB开发的自动更新程序

            '..but the folder path must exist to ensure integrity of the <sp> constant.
            args = Replace(args, Chr(34), "")
            If Dir$(Left$(args, InStrRev(args, "\") - 1), vbDirectory) <> "" Then
                Setup.SetupScriptPath = GetLongPath(args)
            Else
                '//The directory was not found so we must abort LiveUpdate
                If Setup.RunMode = eNORMAL Then '-- Inform the user if in Normal mode, else just exit
                    MsgBox "LiveUpdate could not locate the '" & Left$(args, InStrRev(args, "\") - 1) & _
                           "' directory as expected and must now exit.   " & vbNewLine & vbNewLine & _
                           "If this problem persist please contact the vendor of this software.   ", vbCritical, "LiveUpdate Initialization Script Directory Not Found"
                    
                End If
                Exit Sub
            End If
        End If
    End If
    
    '//If SetupScriptPath was not passed as an argument then default to update.ris in
    '..the App.Path directory. If this file is not found, we will be using ucDownload
    '..settings, and will create the update.ris file when exiting ReVive. If the
    '..ucDownload control does not specify the web script location, ReVive will return
    '..an "Unable to download update script" error.
    '//IMPORTANT: If you always distribute a ris file with your app and pass it, you're good.
    If Len(Setup.SetupScriptPath) = 0 Then
        Setup.SetupScriptPath = App.path & "\update.ris"
    End If
    '//Select a temp directory where the update.ris file is stored or App.Path when no update.ris
    '..file is found or specified.. Doing this ensures updated files do not need moved across volumes,
    '..which would cause us to lose the security descriptor attached to the file.
    sRISDir = Left$(Setup.SetupScriptPath, InStrRev(Setup.SetupScriptPath, "\", , vbTextCompare) - 1)
    sTEMPDIR = sRISDir & "\Temp\ReVive_0000"
    '//Create Temp folder if it does not exist
    If Dir$(sRISDir & "\Temp", vbDirectory) = "" Then
        MkDir sRISDir & "\Temp"
    End If
    '//Select and create a unique temp Revive directory that does not already exist
    Do While Dir$(sTEMPDIR, vbDirectory) <> ""
        x = x + 1
        sTEMPDIR = sRISDir & "\Temp\ReVive_" & Format(x, "0000")
    Loop
    MkDir sTEMPDIR
    bADMIN = IsAdministrator
    bOS = WindowsVersion
    Load frmMain
Errs_Exit:
    Exit Sub
Errs:
    MsgBox "LiveUpdate experienced the following unrecoverable error in Sub Main:" & vbNewLine & vbNewLine & _
            Err.Description & vbNewLine & vbNewLine & _
            "Contact your software vendor if this problem persist.", vbCritical, "LiveUpdate"
        Resume Errs_Exit
End Sub

Public Sub DrawForm(ByVal fForm As Form)
'-------------------------------------------------------------------------
' Purpose   : Central Sub to hide default title bar and draw new one, clip
'             old form region, and draw new border. Used for all forms.
'-------------------------------------------------------------------------
Dim h           As Long
Dim w           As Long
Dim nStyle      As Long
Dim hRgn        As Long
Dim lMenu       As Long
    With fForm
        h = .ScaleHeight
        w = .ScaleWidth
        nStyle = GetWindowLong(.hWnd, GWL_STYLE) '-------- Hide title bar
        nStyle = nStyle And Not WS_CAPTION
        Call SetWindowLong(.hWnd, GWL_STYLE, nStyle)
        SetWindowPos .hWnd, 0, 0, 0, 0, 0, SWP_FLAGS
        hRgn = CreateRectRgn(3, h + 3, w + 3, 3)
        Call SetWindowRgn(.hWnd, hRgn, True)
        DeleteObject hRgn
        Call DrawBorder(.hdc, 0, w, 0, h, RaisedHigh) '--- Draw new form border
        lMenu = GetSystemMenu(.hWnd, False) '------------- Remove Size menu item
        RemoveMenu lMenu, 2, MF_BYPOSITION
        DrawMenuBar .hWnd '------------------------------- Refresh system menu
    End With
End Sub

Public Sub DrawTitleBar(ByVal fForm As Form, ByVal State As WindowState, ByVal sCaption As String, Optional ByVal Buttons As Boolean = False)
Dim r1      As RECT
Dim r2      As RECT
Dim w       As Long
Dim lHdc    As Long
Dim pIcon   As IPictureDisp
    With fForm
        w = .ScaleWidth
        lHdc = .hdc
        '//Draw gradient title bar
        Call SetRect(r1, 2, 2, w - 5, 24)
        Call DrawGradient(lHdc, r1, IIf(State = Active, 3087635, 8487297), 14407116, HORIZONTAL)
        '//Draw title bar text with white text Active or grayed text InActive
        Call SetRect(r2, 6, 6, w - 45, 20)
        .ForeColor = IIf(State = Active, vbWhite, 13423575)
        .FontBold = True
        Call DrawText(lHdc, sCaption, -1, r2, DT_FLAGS + DT_LEFT + DT_NOPREFIX)
        '//Draw Close and Minimize buttons if requested
        If Buttons Then '---- Draw the Close and Minimize buttons from one icon
            Set pIcon = LoadResPicture(206, vbResIcon)
            Call DrawIconEx(fForm.hdc, w - 41, 5, pIcon.Handle, 34, 16, 0, 0, &H3)
            Set pIcon = Nothing
        End If
        '//Repaint only the title bar rect, NOT the entire window.
        '..To illustrate selective repainting change r1 to r2 below.
        Call RedrawWindow(.hWnd, r1, 0&, RDW_FLAGS)
    End With
End Sub

Public Sub Reboot()
'---------------------------------------------------------------------------------------
' Procedure : Reboot
' Author    : Dave Scarmozzino, "The Scarms", http://www.thescarms.com/vbasic/chgres.asp
' Purpose   : Reboots the computer when required.
'---------------------------------------------------------------------------------------
Dim tLuid          As LUID
Dim tTokenPriv     As TOKEN_PRIVILEGES
Dim tPrevTokenPriv As TOKEN_PRIVILEGES
Dim lResult        As Long
Dim lToken         As Long
Dim lLenBuffer     As Long

If bOS < 2 Then '--------- Forget all the AccessToken stuff below if Win9X or ME
    Call ExitWindowsEx(EWX_REBOOT, 0)
Else
    '
    ' Get the access token of the current process.  Get it
    ' with the privileges of querying the access token and
    ' adjusting its privileges.
    '
    lResult = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, lToken)
    If lResult = 0 Then
        Exit Sub 'Failed
    End If
    '
    ' Get the locally unique identifier (LUID) which
    ' represents the shutdown privilege.
    '
    lResult = LookupPrivilegeValue(0&, "SeShutdownPrivilege", tLuid)
    If lResult = 0 Then Exit Sub 'Failed
    '
    ' Populate the new TOKEN_PRIVILEGES values with the LUID
    ' and allow your current process to shutdown the computer.
    '
    With tTokenPriv
        .PrivilegeCount = 1
        .Privileges.Attributes = SE_PRIVILEGE_ENABLED
        .Privileges.pLuid = tLuid
    lResult = AdjustTokenPrivileges(lToken, False, tTokenPriv, Len(tPrevTokenPriv), tPrevTokenPriv, lLenBuffer)
    End With
    
    If lResult = 0 Then
        Exit Sub 'Failed
    Else
        If Err.LastDllError = ERROR_NOT_ALL_ASSIGNED Then Exit Sub 'Failed
    End If
    '
    '  Shutdown Windows.
    '
    Call ExitWindowsEx(EWX_REBOOT, 0)
End If

End Sub

Public Function GetLongPath(ByVal sPath As String) As String
'//If called running Win95 this function will return the string passed to it.
'..This call is only used for consistency when displaying the update report.
On Error Resume Next
Dim lLength  As Long
Dim sBuff    As String
    sBuff = String$(MAX_PATH, 0)
    lLength = GetLongPathName(sPath, sBuff, Len(sBuff))
    If lLength And Err = 0 Then
        GetLongPath = Left$(sBuff, lLength)
    Else
        GetLongPath = sPath
    End If
    If Err Then Err.Clear
End Function

Public Function ProfileGetItem(ByVal lpSectionName As String, _
                               ByVal lpKeyName As String, _
                               ByVal defaultValue As String, _
                               ByVal inifile As String) As String
'************************************************************
'Written by Randy Birch, http://vbnet.mvps.org
'"Using INI Files to Save Application Data - The Basics"
'http://vbnet.mvps.org/index.html?code/file/pprofilebasic.htm
'************************************************************

'Retrieves a value from an ini file corresponding
'to the section and key name passed.
        
   Dim success As Long
   Dim nSize As Long
   Dim ret As String
  
  'call the API with the parameters passed.
  'The return value is the length of the string
  'in ret, including the terminating null. If a
  'default value was passed, and the section or
  'key name are not in the file, that value is
  'returned. If no default value was passed (""),
  'then success will = 0 if not found.

  'Pad a string large enough to hold the data.
   ret = Space$(2048)
   nSize = Len(ret)
   success = GetPrivateProfileString(lpSectionName, _
                                     lpKeyName, _
                                     defaultValue, _
                                     ret, _
                                     nSize, _
                                     inifile)
   
   If success Then
      ProfileGetItem = Left$(ret, success)
   End If
   
End Function

Public Function GetFolderPath(ByVal csidl As CSIDL_VALUES) As String
'****************************************************************************
'Adapted from code written by Randy Birch
'"Using SHGetFolderPath to Find Popular Shell Folders", http://vbnet.mvps.org
'Full post is here: http://vbnet.mvps.org/index.html?code/browse/csidl.htm
'****************************************************************************
Dim buff As String
    buff = Space$(MAX_PATH)
    If SHGetFolderPath(0, csidl Or CSIDL_FLAG_PER_USER_INIT, -1, _
       SHGFP_TYPE_CURRENT, buff) = S_OK Then
           GetFolderPath = Left$(buff, lstrlenW(StrPtr(buff)))
    End If
End Function

Public Sub DrawBorder(ByVal hdc As Long, ByVal LeftX As Long, _
    ByVal RightX As Long, ByVal TopY As Long, _
    ByVal BottomY As Long, _
    Optional BStyle As mBorderStyles = &H6)
'---------------------------------------------------------------------------------------
' Purpose   : Draws border as defined by mBorderStyles
'---------------------------------------------------------------------------------------
Dim R As RECT
    SetRect R, LeftX, TopY, RightX, BottomY '-- Set the rectangle's perimeter values
    If BStyle = FocusRect Then
        DrawFocusRect hdc, R
    Else
        DrawEdge hdc, R, BStyle, BF_RECT
    End If
End Sub

Public Sub DrawGradient(ByVal lHdc As Long, R As RECT, ByVal StartColor As Long, ByVal EndColor As Long, ByVal Direction As ePlane)
Dim s       As RGBColor   'Start RGB colors
Dim e       As RGBColor   'End RBG colors
Dim i       As RGBColor   'Increment RGB colors
Dim x       As Long
Dim lSteps  As Long
    lSteps = IIf(Direction, R.lRight - R.lLeft, R.lBottom - R.lTop)
    s.R = (StartColor And &HFF)
    s.G = (StartColor \ &H100) And &HFF
    s.B = (StartColor And &HFF0000) / &H10000
    e.R = (EndColor And &HFF)
    e.G = (EndColor \ &H100) And &HFF
    e.B = (EndColor And &HFF0000) / &H10000
    With i
        .R = (s.R - e.R) / lSteps
        .G = (s.G - e.G) / lSteps
        .B = (s.B - e.B) / lSteps
        If Direction Then  '-------- HORIZONTAL
            For x = 1 To lSteps
                Call LineApi(lHdc, (lSteps - x) + R.lLeft, R.lTop, (lSteps - x) + R.lLeft, R.lBottom, RGB(e.R + (x * .R), e.G + (x * .G), e.B + (x * .B)))
            Next x
        Else               '-------- VERTICAL
            For x = 1 To lSteps
                Call LineApi(lHdc, R.lLeft, (lSteps - x) + R.lTop, R.lRight, (lSteps - x) + R.lTop, RGB(e.R + (x * .R), e.G + (x * .G), e.B + (x * .B)))
            Next x
        End If
    End With
End Sub

Public Sub LineApi(ByVal lHdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
Dim pt      As POINTAPI
Dim hPen    As Long
Dim hPenOld As Long
    hPen = CreatePen(0, 1, Color)
    hPenOld = SelectObject(lHdc, hPen)
    MoveToEx lHdc, X1, Y1, pt
    LineTo lHdc, X2, Y2
    SelectObject lHdc, hPenOld
    DeleteObject hPen
End Sub

Public Sub ShowSysMenu(ByVal lHwnd As Long, ByVal x As Long, ByVal y As Long)
   '//NOTE: Must be in screen coordinates.
   Call SendMessage(lHwnd, WM_GETSYSMENU, 0, ByVal GetLong(y, x))
End Sub