frmupdate.frm

VB仿LiveUpdate自动更新程序.比较实用的一个功能

Private Sub Step(Number As Integer)
    Dim blnUpdate As Boolean
    Select Case Number
        Case 1   'Form load
        Me.lblCaption.Caption = "欢迎使用" & AppName & "在线升级程序."
        Me.lblInfo.Caption = "本程序将帮助您将您的" & AppName & "升级为最新版本.升级前请检查是否连接到互联网."
        Me.lblEnd.Caption = "单击下一步继续 LiveUpdate"
        Case 2
        Me.lblCaption.Caption = "Internet 连接"
        Me.lblInfo = "LiveUpdate 将连接到服务器." & vbCrLf & vbCrLf & "如果您没有连接, LiveUpdate 将自动进行连接." & vbCrLf
        Me.lblEnd.Caption = "单击下一步继续."

        Case 3
        Me.cmdNext.Enabled = False
        Me.cmdBack.Enabled = False
        If FTPConnect = True Then
            Me.cmdNext.Enabled = True
            Me.lblCaption.Caption = "您正在连接服务器"
            Me.lblInfo = "现在 LiveUpdate 将分析服务器上否有可用的最新更新."
            Me.lblEnd.Caption = "单击下一步继续检查可用更新"
        Else
            frmLiveUpdate!lblEnd.Caption = "无法建立连接"
            Me.lblCaption = "连接错误!"
            Me.lblInfo = ""

            Me.cmdNext.Enabled = True
            Me.cmdNext.Caption = "完成"
            Me.cmdBack.Enabled = False
            Me.cmdCancel.Enabled = False
            Exit Sub
        End If
        Case 4
        blnUpdate = SendFiles("LiveUpdate")
        If blnUpdate = False Then
            Me.cmdNext.Caption = "完成"
            Me.cmdBack.Enabled = False
            Me.cmdCancel.Enabled = False
            Me.lblCaption.Caption = "感谢您使用 LiveUpdate"
            Me.lblInfo = "此时服务器没有可用的更新文件."
            Me.lblEnd.Caption = "单击 完成 退出"
        Else
            Me.lblCaption.Caption = "感谢您使用 LiveUpdate"
            Me.lblInfo.Caption = "已完成 LiveUpdate更新!"
        End If
    End Select

    If Number > 1 And Number < 4 Then
        Me.cmdBack.Enabled = True
    Else
        Me.cmdBack.Enabled = False
    End If
End Sub

Public Function FTPConnect() As Boolean
    Screen.MousePointer = 11
    FTP_Server = GetIniParam(App.Path & "\LiveUpdate.ini", "LiveUpdate", "Host")
    FTP_User = GetIniParam(App.Path & "\LiveUpdate.ini", "LiveUpdate", "User")
    FTP_Pass = Decrypt(GetIniParam(App.Path & "\LiveUpdate.ini", "LiveUpdate", "Pass"))

    Dim nFlag As Long
    'MousePointer = vbHourglass
    frmLiveUpdate!lblEnd.Caption = "正连接到服务器..."
    DoEvents
    hOpen = InternetOpen(FTP_UAgent, INTERNET_OPEN_TYPE_DIRECT, _
            vbNullString, vbNullString, 0)

    If hOpen <> 0 Then
        hConnection = InternetConnect(hOpen, FTP_Server, _
                      INTERNET_INVALID_PORT_NUMBER, _
                      FTP_User, _
                      FTP_Pass, _
                      INTERNET_SERVICE_FTP, nFlag, 0)

        If hConnection <> 0 Then
            frmLiveUpdate!lblEnd.Caption = "您已经连接到服务器"
            FTPConnect = True
        Else
            FTPConnect = False
        End If
    Else
        FTPConnect = False
    End If
    Screen.MousePointer = 0
End Function

Private Sub Form_Unload(Cancel As Integer)
    Call InternetCloseHandle(hConnection)
    Call InternetCloseHandle(hOpen)
End Sub

Public Function SendFiles(vName As String) As Boolean
    Dim x            As Integer
    Dim strFiles     As String
    Dim strPath      As String
    Dim SizeFile     As Long
    Dim pData        As WIN32_FIND_DATA
    Dim hFile        As Long
    Dim hRet         As Long
    Dim lTime        As FILETIME
    Dim sTime        As SYSTEMTIME
    Dim strFTPTime   As String
    Dim strLocalTime As String
    Dim intNbrPasse  As Integer
    Dim BlnResult    As Boolean
    Me.Timer.Enabled = True
    intNbrPasse = 0
    Me.lblEnd.Caption = "正在检查更新...."
    For x = 1 To 99
        strFiles = GetIniParam(App.Path & "\LiveUpdate.ini", vName, "FILES" & x)
        strPath = GetIniParam(App.Path & "\LiveUpdate.ini", vName, "PATH" & x)

        If strFiles <> "" Then
            Call ResetPB
            pData.cFileName = String$(MAX_PATH, 0)
            hFile = FtpFindFirstFile(hConnection, Trim$(strFiles), pData, 0, 0)
            If hFile = 0 Then Exit For
            hRet = InternetFindNextFile(hFile, pData)
            SizeFile = pData.nFileSizeLow
            glbSize = SizeFile
            lTime = pData.ftLastWriteTime

            l = FileTimeToSystemTime(lTime, sTime)
            strFTPTime = GetFileDateString(pData.ftLastWriteTime)
            strLocalTime = RetFileDate(strPath)
            If strFTPTime <= strLocalTime Then
                Me.lblEnd.Caption = "当前文件无可用更新 " & strFiles
            Else
                frmTransfert.Visible = True
                intNbrPasse = intNbrPasse + 1
                BlnResult = GetFiles(strFiles, strPath, SizeFile, 1)

            End If
            strFiles = ""
            Call InternetCloseHandle(hFile)
            Call InternetCloseHandle(hRet)
            hFile = 0
            hRet = 0
        Else
            Me.cmdCancel.Caption = "关闭"
            Me.Timer.Enabled = False
            Me.lbl_Time.Caption = ""
        End If
    Next x

    If intNbrPasse = 0 Then
        Me.lblEnd.Caption = "此刻无可用更新!"
        Me.cmdBack.Enabled = False
        Me.cmdCancel.Enabled = False
        Me.cmdNext.Caption = "结束"
        SendFiles = False
    Else
        If BlnResult = True Then
            Me.lblEnd.Caption = "更新完成，共 " & intNbrPasse & " 个文件被更新 !"
            blnNewUpdate = True
            Me.cmdBack.Enabled = False
            Me.cmdCancel.Enabled = False
            Me.cmdNext.Caption = "完成"
            SendFiles = True
        Else

        End If
    End If

End Function

Private Function ResetPB()
    Me.Percent.Width = 15
    Me.txtPercent.Caption = ""

    Me.Lbl_FileSize.Caption = ""
    Me.Lbl_Averages.Caption = ""
    Me.lbl_Time.Caption = ""
End Function

Public Function GetFiles(strFile As String, strNewFile As String, lngFileSize As Long, vMode As Integer) As Boolean
   Dim hFile                  As Long
   Dim sBuffer                As String
   Dim sReadBuffer            As String * 4096
   Dim lNumberOfBytesRead     As Long
   Dim bDoLoop                As Boolean
   Dim Sum                    As Long
   Dim x                      As Integer
   GetFiles = True
   
   If vMode = 0 Then  '
       Transfer = FTP_TRANSFER_TYPE_ASCII
   Else
       Transfer = FTP_TRANSFER_TYPE_BINARY
   End If
   InProgress = True
   hFile = FtpOpenFile(hConnection, Trim(strFile), GENERIC_READ, Transfer, 0)
   Open strNewFile For Binary Access Write As #2
   
   bDoLoop = True
   StopTransfert = False
   
   While bDoLoop
      DoEvents
      If StopTransfert = True Then
         Close #2
         Kill strNewFile
         
         For x = 1 To 10000
             DoEvents
         Next x
         GetFiles = False
         Call ResetPB
         GoTo StopGetFiles
      End If
      
      sReadBuffer = vbNullChar
      bDoLoop = InternetReadFile(hFile, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
      sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
      If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
      Sum = Sum + lNumberOfBytesRead
      Call ProgressBar(lngFileSize, Str(Sum), strFile)
      Put #2, , sBuffer
      sBuffer = ""
   Wend
         
StopGetFiles:
   Close #2
   InternetCloseHandle (hFile)
   
End Function


Private Sub Timer_Timer()
    Dim Nbrk As Long
    Nbrk = DoneBytes - OldBytes
    If Nbrk > 0 Then
        Lbl_Averages.Refresh
        lbl_Time.Refresh
        Lbl_Averages.Caption = "平均速度 : " & Format$(Nbrk / 1024, "###0.0") & " / Kbps"
        lbl_Time.Caption = ConvSeconde(((glbSize - DoneBytes) / (Nbrk / 1024) / 1024))
    End If
    OldBytes = DoneBytes
End Sub

Public Function ProgressBar(Size, Done, Files)
    '进度条显示
    If Done = 0 Then Exit Function
    Dim iSendPercent As Integer
    Dim x            As Integer

    iSendPercent = (Done / Size) * 100
    If iSendPercent >= 50 Then
        frmLiveUpdate.txtPercent.ForeColor = 16777215
    Else
        frmLiveUpdate.txtPercent.ForeColor = 0
    End If

    DoneBytes = Done
    frmLiveUpdate.frmTransfert.Caption = "传输文件 " & Trim$(Files)
    frmLiveUpdate.Percent.Width = 41.5 * iSendPercent
    frmLiveUpdate.Percent.Caption = iSendPercent & " %"
    frmLiveUpdate.Percent.Refresh
    frmLiveUpdate.Lbl_FileSize.Caption = Format$(Done / 1000, "###0.0") & "Kb / " & Format$(Size / 1000, "###0.0") & " Kb"
    DoEvents
End Function