frmmain.frm

VB开发的自动更新程序

        '..in ucDownload control on frmMain.
        If Len(.AppShortName) = 0 Or Len(.AppLongName) = 0 Or Len(.ScriptURLPrim) = 0 Then
            Call CleanUp '--------------------- Delete all temp folders
            If Setup.RunMode = eNORMAL Then
                MsgBox "LiveUpdate 无法获取程序最新更新现在将关闭.  ", vbCritical, "错误"
            End If
            End '------------------------------ Terminate ReVive
        End If
    End With
    Set Me.Picture = LoadResPicture(300, 0) '-- Load form graphic from resource file
    Call DrawForm(Me) '------------------------ Clip the form and draw new border
    If Setup.RunMode = eNORMAL Then '---------- Skip in eNOTIFY and eAUTO modes
        Me.lblOpening.Caption = "LiveUpdate 将为你的程序检查有效的更新 " & _
            Setup.AppLongName & " 并安装." & vbNewLine & vbNewLine & _
            "请确保 " & Setup.AppShortName & " 已关闭而且连接到 " & _
            "网络后再继续." & Chr(13) & Chr(13) & _
            "单击下一步开始继续更新或者单击取消中止更新退出程序."
        Me.Show '------------------------------ Display form for Normal mode
        Call cmdNext_FormActivate(Active) '---- Draw title bar and text (force because skipped while invisible)
    Else
        SetForegroundWindow lPREVWINDOW '------ Return focus to previously active window
        cmdNext_Click '------------------------ Proceed for eAUTO or eNOTIFY modes
    End If
    SetRect R, 108, 285, 504, 331 '------------ Draw gradient behind XP buttons and refresh RECT
    Call DrawGradient(Me.hdc, R, &HEBEDED, 11447982, VERTICAL)
    If Me.Visible Then Call RedrawWindow(Me.hWnd, R, 0&, RDW_FLAGS)
    Call SetRect(R, 2, 313, 108, 325) '------ Draw version info on bottom left of form
    Call DrawText(Me.hdc, "version " & App.Major & "." & App.Minor, -1, R, DT_FLAGS + DT_LEFT + DT_NOPREFIX + DT_CENTER)
    '//Repaint only the version info rect, NOT the entire window
    If Me.Visible Then Call RedrawWindow(Me.hWnd, R, 0&, RDW_FLAGS)
End Sub

Private Sub Form_Activate()
On Error Resume Next
    If Me.Visible Then Me.cmdNext.SetFocus '--- Return focus to cmdNext when returning from other forms
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
'----------------------------------------------------------------------------------
' Purpose   : Either minimizes, closes, or move the form (depending on x and y)
'----------------------------------------------------------------------------------
On Error Resume Next
Dim R As RECT
    If Button = vbLeftButton Then
        Call SetRect(R, 486, 5, 502, 21) '------------ Minimize button
        If PtInRect(R, CLng(x), CLng(y)) Then
            Unload Me
            Exit Sub
        End If
        Call SetRect(R, 468, 5, 484, 21) '------------ Close button
        If PtInRect(R, CLng(x), CLng(y)) Then
            Me.WindowState = 1
            Exit Sub
        End If
        Call SetRect(R, 0, 0, Me.ScaleWidth, 24) '---- All other titlebar clicks
        If PtInRect(R, CLng(x), CLng(y)) Then
            SetCursor LoadCursor(0, IDC_SIZEALL)
            Call ReleaseCapture
            Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
            Exit Sub
        End If
    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
'---------------------------------------------------------------------------------
' Purpose   : Display system menu when user clicks our title bar RECT only
'---------------------------------------------------------------------------------
Dim pt  As POINTAPI
Dim R   As RECT
   If Button = vbRightButton Then
        Call SetRect(R, 0, 0, Me.ScaleWidth, 24)
        If PtInRect(R, CLng(x), CLng(y)) Then '-------- See if we are in the title bar area
            Call GetCursorPos(pt) '-------------------- Must use screen coordinates
            Call ShowSysMenu(Me.hWnd, pt.x, pt.y) '---- Popup forms system menu
        End If
   End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
Dim sFile As String
    If Len(sUpdateMessage) Then
        Me.Hide
        frmUpdateMessage.Show 1 '--------------------------- Display update messages
    End If
    If Not bJustExit And Setup.RunMode = eNORMAL Then
        If frmExit.ShowYesNo = Yes Then
            sFile = Dir$(sTEMPDIR & "\*.*")
            Do While sFile <> ""
                Call DeleteFile(sTEMPDIR & "\" & sFile) '--- Delete ALL files that may have been downloaded so far
                sFile = Dir$(sTEMPDIR & "\*.*")
            Loop
        Else
            Cancel = 1
            Exit Sub
        End If
    End If
    If bREBOOT Then Call Reboot  '------------ Reboot computer
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Dim f As Form
    If bWriteScript Then WriteSetupScript '--- Write local ReVive initialization script
    For Each f In Forms '--------------------- Ensure all forms are unloaded
        Unload f
    Next f
    Call CleanUp '---------------------------- Delete un-needed files and temp directory
    Set frmMain = Nothing
    End '------------------------------------- Required only when running in Auto or Notify
        '...---------------------------------- mode to exit form load event following call to
        '...---------------------------------- cmdNext_Click. If ommitted, error will occurr
        '...---------------------------------- if update script is not found on server and
        '...---------------------------------- we are in Auto or Notify modes only.
End Sub

Private Sub CleanUp()
'--------------------------------------------------------------------------------
' Purpose   : Deletes all downloaded files not reserved for post reboot updating.
'--------------------------------------------------------------------------------
On Error Resume Next
Dim x   As Long
Dim s   As String
Dim u   As Long
    With FileList '----------------------- Delete all files not reserved for post reboot updating
        u = UBound(.TempPath)
        For x = 1 To u
            If .Status(x) <> UPDATECOMPREBOOT Then
                Call DeleteFile(.TempPath(x) & ".tmp")
            End If
        Next x
    End With
    Call DeleteFile(sTEMPDIR & "\Notify.ico") '-- Delete Notification icon
    '//Temp folder deletes will only succeed if no files are remaining for post reboot update.
    '..All remaining files will be deleted on reboot after update via registry or WinInit.ini.
    s = Dir$(CurDir$) '------------------- Remove VB's directory lock on sTempDir
    Call RemoveDirectory(sTEMPDIR) '------ Remove our temp directories if empty
    Call RemoveDirectory(Left$(sTEMPDIR, InStrRev(sTEMPDIR, "\", , vbTextCompare) - 1))
End Sub

Private Sub AltLVBackground(lv As ListView, _
    Optional ByVal BackColorOne As OLE_COLOR = vbWhite, _
    Optional ByVal BackColorTwo As OLE_COLOR = 16054263) '--- 16054263 = Lite Gray
'-----------------------------------------------------------------------------------------------
' Purpose   : Alternates colors in a ListView
' PSC Post  : http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=51229&lngWId=1
'-----------------------------------------------------------------------------------------------
Dim h               As Single
Dim sw              As Single
Dim lScaleMode      As Integer
Dim picAlt          As PictureBox
    lScaleMode = lv.Parent.ScaleMode
    lv.Parent.ScaleMode = vbTwips
    Set picAlt = Me.Controls.Add("VB.picturebox", "picAlt")
    '//Draws the desired backcolor scheme in the picAlt picturebox
    '..then loads the image in the passed listviews picture.
    With lv
        If .View = lvwReport Then
            If .ListItems.Count Then
                .PictureAlignment = lvwTile
                h = .ListItems(1).Height
                With picAlt
                    .BackColor = BackColorOne
                    .BorderStyle = 0
                    .AutoRedraw = True
                    .Height = h * 2
                    .Width = 10 * Screen.TwipsPerPixelX
                    sw = .ScaleWidth
                    picAlt.Line (0, h)-Step(sw, h), BackColorTwo, BF
                    Set lv.Picture = .Image
                    Set .Picture = Nothing
                End With
            End If
        End If
    End With
    Set picAlt = Nothing
    Me.Controls.Remove "picAlt"
    lv.Parent.ScaleMode = lScaleMode
End Sub

Private Function EncryptString(ByVal sString As String) As String
'---------------------------------------------------------------------------------------
' Purpose   : Encrypts web URL strings prior to entry into the initialization script.
'             Only called from the WriteSetupScript sub.
'---------------------------------------------------------------------------------------
Dim x       As Integer
Dim y       As Integer
Dim sBuffer As String
    If Len(CRYPTPWD) Then
        For x = 1 To Len(sString)
            y = Asc(Mid$(sString, x, 1))
            y = y + Asc(Mid$(CRYPTPWD, (x Mod Len(CRYPTPWD)) + 1, 1))
            sBuffer = sBuffer & Chr$(y And &HFF)
        Next x
        EncryptString = sBuffer
    Else
        EncryptString = sString
    End If
End Function

Private Function DecryptString(ByVal sString As String) As String
'---------------------------------------------------------------------------------------
' Purpose   : Decrypts web URL strings when reading from the initialization script.
'             Only called from the Form_Load event.
'---------------------------------------------------------------------------------------
Dim x       As Integer
Dim y       As Integer
Dim sBuffer As String
    If Len(CRYPTPWD) Then
        For x = 1 To Len(sString)
            y = Asc(Mid$(sString, x, 1))
            y = y - Asc(Mid$(CRYPTPWD, (x Mod Len(CRYPTPWD)) + 1, 1))
            sBuffer = sBuffer & Chr$(y And &HFF)
        Next x
        DecryptString = sBuffer
    Else
        DecryptString = sString
    End If
End Function

Private Sub WriteSetupScript()
'----------------------------------------------------------------------------------------
' Purpose   : Creates local LiveUpdate initialization file for this app that will be
'             used next time to provide ScriptURL's, file version numbers, and app title.
'             This functionality allows the app developer to alternate script URL's
'             for planned server changes, or to change the LiveUpdate app title display.
'             Values provided in the on-line script are written locally for next time.
'----------------------------------------------------------------------------------------
On Error Resume Next
Dim x       As Long
Dim f       As Integer
Dim s       As String
Dim sEXT    As String
    s = vbNewLine
    With Setup
        s = s & .AppShortName & " ReVive初始化脚本"
        s = s & vbNewLine & vbNewLine
        s = s & "--------------------------------------------------------------------------------"
        s = s & vbNewLine
        s = s & "***WARNING: MODIFYING THIS SCRIPT MAY CAUSE LIVEUPDATE TO FUNCTION IMPROPERLY***"
        s = s & vbNewLine & vbNewLine
        s = s & "[Setup]" & vbNewLine
        s = s & "AppShortName=" & .AppShortName & vbNewLine
        s = s & "AppLongName=" & .AppLongName & vbNewLine
        s = s & "ScriptURLPrim=" & EncryptString(.ScriptURLPrim) & vbNewLine
        s = s & "ScriptURLAlt=" & EncryptString(.ScriptURLAlt) & vbNewLine
        s = s & "LastChecked=" & Format(.LastChecked, "dd mmm yyyy") & vbNewLine & vbNewLine
    End With
    s = s & "[Files]" & vbNewLine
    With FileList
        For x = 1 To UBound(.Description)
            '//For non EXE, OCX and DLL files, write version info to setup script.
            '..Version info for EXE, OCX and DLL files is extracted from the files
            '..and will not be needed in the script.
            sEXT = "|" & GetFileExt(.InstallPath(x)) & "|"
            If InStr(1, "|EXE|OCX|DLL|", sEXT) = 0 Then
                If .Status(x) = UPDATECOMP Then
                    s = s & .Description(x) & "=" & .UpdateVersion(x) & vbNewLine
                Else
                    s = s & .Description(x) & "=" & .CurrentVersion(x) & vbNewLine
                End If
            End If
        Next x
    End With
    s = s & vbNewLine
    s = s & "***WARNING: MODIFYING THIS SCRIPT MAY CAUSE LIVEUPDATE TO FUNCTION IMPROPERLY***"
    s = s & vbNewLine
    s = s & "--------------------------------------------------------------------------------"
    f = FreeFile
    Open Setup.SetupScriptPath For Output As #f
        Print #f, s
    Close #f
End Sub

Private Sub UpdateIcon(ByVal FileNumber As Integer)
'---------------------------------------------------------------------------------------
' Purpose   : Updates a files listview icon when the file is downloaded.
'             Only called from ucDownloadComplete and only when icons need updated.
'---------------------------------------------------------------------------------------
On Error Resume Next
Static l As Integer
    If l = 0 Then l =