frmmain.frm

VB开发的自动更新程序

                    bAppKilled = Not IsAppRunning(.UpdateAppTitle, .UpdateAppClass)
                    Erase tRunningApps.lWndHwnd: Erase tRunningApps.lWndProcessID
                End If
            End If
        End If
    End With
    If VerifyInstallReady Then '------ Make sure *ALL* updates pass test before installing any.
        With FileList '--------------- Atleast one update is ready and none caused an abort.
            For x = 1 To UBound(.Description)
                If .Status(x) = UPDATEREADY Then
                    lResult = UpdateFile(.TempPath(x), .InstallPath(x)) '- Initiate update
                    Select Case lResult
                        Case 0 '------- Success
                            .Status(x) = UPDATECOMP
                            Me.lvFiles.ListItems(x).ListSubItems(1) = "更新完毕"
                            If Len(.UpdateMessage(x)) Then '-------------- Store Update Message
                                sUpdateMessage = sUpdateMessage & .Description(x) & " - " & .UpdateMessage(x) & vbNewLine & vbNewLine
                            End If
                        Case 1 '------- Success, reboot required
                            .Status(x) = UPDATECOMPREBOOT
                            Me.lvFiles.ListItems(x).ListSubItems(1) = "需要重新启动"
                            If Len(.UpdateMessage(x)) Then '-------------- Store Update Message
                                sUpdateMessage = sUpdateMessage & .Description(x) & " - " & .UpdateMessage(x) & vbNewLine & vbNewLine
                            End If
                            bREBOOT = True
                        Case 4 '------- Insufficient privilege
                            .Status(x) = INSUFFPRIVILEGE
                            Me.lvFiles.ListItems(x).ListSubItems(1) = "Permission Denied"
                        Case Else '---- Misc errors
                            .Status(x) = ERRUPDATING
                            Me.lvFiles.ListItems(x).ListSubItems(1) = "更新失败"
                    End Select
                End If
                '//All updates have now been attempted, let's display results...
                If Not bErrors Then '-- Prepare to display caption when done
                    If .Status(x) = ERRCONNECTING Or _
                            .Status(x) = ERRTRANSFERRING Or _
                            .Status(x) = ERRUPDATING Or _
                            .Status(x) = FILENOTINSTALLED Or _
                            .Status(x) = INSUFFPRIVILEGE Then
                       bErrors = True
                    End If
                End If
            Next x
        End With
        If bErrors Then
            Me.frmList.Caption = "在线更新完成但发现错误."
        Else
            Me.frmList.Caption = "在线更新完成."
        End If
        If bREBOOT Then
            Me.cmdNext.Caption = "现在重启(&N)"
            With Me.cmdCancel
                If Setup.ForceReboots = 0 Then
                    .Caption = "稍候重启(&L)"
                    .Visible = True
                Else
                    .Visible = False
                End If
            End With
            Me.cmdReport.Caption = "报告(&R)"
            Me.lblContinue.Caption = "选择报告可以查看详情或者现在重启以完成更新."
        Else
            Me.cmdNext.Caption = "退出(&E)"
            With Me.cmdReport
                .Caption = "报告(&R)"
                .Move Me.cmdCancel.Left, Me.cmdCancel.Top
                .Visible = True
            End With
            Me.cmdCancel.TabStop = False
            Me.lblContinue.Caption = "选择报表查看详情或者退出关闭更新."
        End If
        With Me.cmdNext
            .Enabled = True
            If Me.Visible Then .SetFocus
        End With
        If Setup.RunMode = eAUTO Then '--- Popup updates completed notify form above taskbar
            frmNotify.Notify True
        End If
        bJustExit = True '---------------- Skip Yes/No exit dialog
        bStep = 2
    End If
    If bAppKilled And Not bREBOOT Then '-- Launch killed app now if requested
        If Len(Setup.LaunchIfKilled) Then
            If Setup.RunMode = eNORMAL Then Screen.MousePointer = vbHourglass
            Me.cmdNext.Enabled = False '-- Disable Exit until timer expires
            ShellExecute 0&, "open", Setup.LaunchIfKilled, vbNullString, vbNullString, SW_NORMAL
            Sleep 2000 '------------------ Allow the restarted app time to load before shifting focus to ReVive
            With Me.cmdNext
                .Enabled = True
                .SetFocus
            End With
        End If
    End If
Errs_Exit:
    SetForegroundWindow Me.hWnd '--------- Return ReVive to the foremost window
    Screen.MousePointer = vbDefault
    Exit Sub
Errs:
    bJustExit = True
    Unload Me
End Sub

Private Function VerifyInstallReady() As Boolean
'--------------------------------------------------------------------------------------------
' Purpose   : Validates files are ready for install by testing for obvious show-stoppers
'             that often occur during the update process. Notice all files are tested before
'             ReVive installs any one update. This ensures integrity of your MustUpdate flags.
'             Due to the nature of this app, thorough update testing is the highest priority.
'             Only called from the InstallUpdates sub just prior to updating files.
'
' Returns   : True = Atleast one file can be updated and no MustUpdate files caused an abort.
'             False = Atleast one file caused an abort or no files passed update test.
'
' Note      : Updating the listview seems uneccessary here, and will be if all files pass
'             and the updates follow (because it will happen so fast). BUT...if no files
'             cause an abort but none remain updatable, the listview will provide why.
'--------------------------------------------------------------------------------------------
On Error GoTo Errs
Dim x           As Long
Dim bContinue   As Boolean
    With FileList
        For x = 1 To UBound(.Description)
            If .Status(x) = DOWNLOADED Then '------------- Only test successful downloads
                Select Case TestUpdateSuccess(.TempPath(x), .InstallPath(x))
                    Case eupdINSUFFPRIV
                        .Status(x) = INSUFFPRIVILEGE
                        If .MustUpdate(x) Then '---------- Required-abort
                            If Setup.RunMode <> eNORMAL Then GoTo UnloadNow
                            Call ShowLiveUpdateError(eluPERMISSIONERR)
                            Exit Function
                        Else '---------------------------- File not required - continue
                            With Me.lvFiles.ListItems(x)
                                .SubItems(1) = "需要管理员权限"
                                .ForeColor = vbRed
                                .ListSubItems(1).ForeColor = 255
                            End With
                            DoEvents '-------------------- Required to visually update ListView
                        End If
                    Case eupdDESTINVALID, eupdSOURCENOTFOUND, eupdUNKNOWNERR
                        If .MustUpdate(x) Then '---------- Required-abort
                            If Setup.RunMode <> eNORMAL Then GoTo UnloadNow
                            Call ShowLiveUpdateError(eluFILEPROCESSERR)
                            Exit Function
                        Else
                            .Status(x) = ERRUPDATING '---- File not required - continue
                            With Me.lvFiles.ListItems(x)
                                .SubItems(1) = "更新测试失败"
                                .ForeColor = vbRed
                                .ListSubItems(1).ForeColor = 255
                            End With
                            DoEvents '-------------------- Required to visually update ListView
                        End If
                    Case Else
                        bContinue = True
                        .Status(x) = UPDATEREADY
                End Select
            End If
        Next x
    End With
    '//If there are any UPDATEREADY files continue, otherwise prepare to exit ReVive.
    If bContinue Then
        '//No single update caused an abort and atleast one file is ready to install.
        VerifyInstallReady = True
    Else
        '//There are no updates ready after tests above, but none caused an abort.
        If Setup.RunMode <> eNORMAL Then GoTo UnloadNow '-- Bolt if in auto or notify mode
        Me.frmList.Caption = "在此时没有资料准备安装 ..."
        Me.lblContinue.Caption = "单击退出将关闭更新程序."
        Me.cmdCancel.Caption = "报告(&R)"
        bJustExit = True '--------------------------------- Skip Yes/No exit dialog
        bStep = 2
        With Me.cmdNext
            .Caption = "退出(&E)"
            .Enabled = True
            If Me.Visible Then .SetFocus
        End With
    End If
Errs_Exit:
    Exit Function
Errs:
    If Setup.RunMode <> eNORMAL Then GoTo UnloadNow '------ Bolt if in Notify or Auto mode
    Call ShowLiveUpdateError(eluFILEPROCESSERR)
    Resume Errs_Exit
UnloadNow:
    bJustExit = True
    Unload Me
End Function

Private Sub ResetProgressBar()
'-----------------------------------------------------------------------
' Purpose   : Adjusts total update download size and bytes received
'             to reflect accurate progress after a file transfer fails
'             or incorrect file size is specified in web update script.
'             Called from ucDL_DownloadComplete or ucDL_DownloadProgress
'-----------------------------------------------------------------------
On Error Resume Next
Dim x As Long
    lTotalDlSize = 0
    lRecvdBytes = 0
    With FileList
        For x = 1 To UBound(.Description)
            If .Status(x) = DOWNLOADED Or .Status(x) = UPDATEREQ Or .Status(x) = DOWNLOADING Then
                lTotalDlSize = lTotalDlSize + .FileSize(x)
                If .Status(x) = DOWNLOADED Then
                    lRecvdBytes = lRecvdBytes + .FileSize(x)
                End If
            End If
        Next x
    End With
    Me.pbDownload.Value = (lRecvdBytes / lTotalDlSize) * 100 '--- Correct progress bar
End Sub

Private Sub ShowLiveUpdateError(ByVal ErrType As eluErrors)
'-------------------------------------------------------------------
' Purpose   : Central procedure to display LiveUpdate errors to user
'-------------------------------------------------------------------
Dim sT  As String
Dim sE  As String
    Set Me.imgWarnIcon.Picture = LoadResPicture(201, 1) '----- Load warning icon from resource file
    Select Case ErrType
        Case eluSCRIPTDLERR
            sT = "LiveUpdate 无法下载这些更新脚本."
            sE = LoadResString(400) '--- Connection error explanation
        Case eluSCRIPTPROCERR
            sT = "LiveUpdate 无法更新脚本过程."
            sE = LoadResString(401) '--- Script process error explanation
        Case eluPERMISSIONERR
            sT = "更新需要管理员权限."
            sE = LoadResString(402) '--- Premission error explanation
        Case eluFILEDOWNLOADERR
            sT = "LiveUpdate 无法下载全部需要的更新文件."
            sE = LoadResString(403) '--- Required file download error explanation
        Case eluFILEPROCESSERR
            sT = "LiveUpdate 无法在程序运行时更新文件."
            sE = LoadResString(404) '--- File processing error explanation
        Case eluSCRIPTEMPTY
            sT = "LiveUpdate 无法提取有效的更新列表."
            sE = LoadResString(405) '--- Script empty error explanation
    End Select
    Me.lblErrTitle.Caption = sT
    Me.lblErrExplain.Caption = sE
    Me.cmdCancel.Visible = False
    bJustExit = True '------------------ Exit without Yes/No dialog
    With Me.cmdNext
        .Caption = "退出(&E)"
        .Enabled = True
        .SetFocus
    End With
    With Me.frmError
        .ZOrder 0
        .Visible = True
    End With
    Screen.MousePointer = vbDefault
    bStep = 2
End Sub

Private Sub cmdNext_FormActivate(State As WindowState)
'-----------------------------------------------------------------------------------------
' Purpose   : Draw title bar and text Active and Deactive as form changes Windows foremost.
'             Sub is raised from cmbNext (XPButton) subclassing, "FormActivate" event.
'------------------------------------------------------------------------------------------
On Error Resume Next
    If Me.WindowState <> vbMinimized And Me.Visible Then
        Call DrawTitleBar(Me, State, Setup.AppShortName & " LiveUpdate", Not bREBOOT)
    End If
End Sub

Private Sub Form_Load()
Dim R   As RECT
Dim w   As Long
    w = Me.ScaleWidth
    With Setup '------------------------------- Get LiveUpdate settings from .ris file or ucDownload
        .AppShortName = Left$(ProfileGetItem("Setup", "AppShortName", Me.ucDL.dAppShortName, .SetupScriptPath), 20)
        .AppLongName = ProfileGetItem("Setup", "AppLongName", Me.ucDL.dAppLongName, .SetupScriptPath)
        .NotifyIcon = ProfileGetItem("Setup", "NotifyIcon", "", .SetupScriptPath)
        .ScriptURLPrim = DecryptString(ProfileGetItem("Setup", "ScriptURLPrim", "", .SetupScriptPath))
        .ScriptURLAlt = DecryptString(ProfileGetItem("Setup", "ScriptURLAlt", "", .SetupScriptPath))
        .LastChecked = ProfileGetItem("Setup", "最后检查", "未知更新", .SetupScriptPath)
        If Len(.ScriptURLPrim) = 0 Then .ScriptURLPrim = Me.ucDL.dScriptURLPrim
        If Len(.ScriptURLAlt) = 0 Then .ScriptURLAlt = Me.ucDL.dScriptURLAlt
        If Len(.LastChecked) Then Me.lblLastUpdated.Caption = "最后检查: " & .LastChecked
        '//Verify we have an app to update before continuing any further. This situation will only
        '..occur if the ccDownload values are not entered and the ris file cannot be found.
        '..To avoid this scenerio, provide App short and long names, and ScriptURLPrim values