frmdownload.frm

在线升级的例子 在线升级的例子

      Width           =   1890
   End
   Begin VB.Label lblVersion 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "version no."
      Height          =   195
      Left            =   180
      TabIndex        =   8
      Top             =   4890
      Width           =   780
   End
   Begin VB.Image Image1 
      Height          =   30
      Left            =   240
      Picture         =   "frmDownload.frx":4521
      Top             =   4320
      Width           =   6660
   End
   Begin VB.Label lblDiscriptonsHeader 
      BackStyle       =   0  'Transparent
      Caption         =   "在线更新程序正在下载所需要的更新文件."
      Height          =   375
      Left            =   2280
      TabIndex        =   7
      Top             =   600
      Width           =   4095
   End
End
Attribute VB_Name = "frmDownload"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'/**********************************************************************
'  在线升级程序，海阔天空
'  Play78.com : 网站导航，源码之家，绝对开源
'  海阔天空收集整理
'  http://www.play78.com/
'  e-mail:[e-mail]
' **********************************************************************

Option Explicit

Dim Data As String
Dim Percent%
Dim BeginTransfer As Single
Dim BytesAlreadySent As Single
Dim BytesRemaining As Single
Dim Header As Variant
Dim Status As String
Dim TransferRate As Single
Dim News As String

Private Sub Form_Load()
lblVersion.Caption = "Version " & App.Major & "." & App.Minor
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
lstList.Nodes.Add , , "Tracker", "Tracker", 1
RESUMEFILE = False
strFormLoaded = "Main"
    StartUpdate txtWebsite.Text
    frmSave.Show
    aniAnimation.AutoPlay = True
End Sub

Function ConvertTime(TheTime As Single)
    Dim NewTime As String
    Dim Sec As Single
    Dim Min As Single
    Dim H As Single

    If TheTime > 60 Then
        Sec = TheTime
        Min = Sec / 60
        Min = Int(Min)
        Sec = Sec - Min * 60
        H = Int(Min / 60)
        Min = Min - H * 60
        NewTime = H & ":" & Min & ":" & Sec
        If H < 0 Then H = 0
        If Min < 0 Then Min = 0
        If Sec < 0 Then Sec = 0
        NewTime = Format(NewTime, "HH:MM:SS")
        ConvertTime = NewTime
    End If


    If TheTime < 60 Then
        NewTime = "00:00:" & TheTime
        NewTime = Format(NewTime, "HH:MM:SS")
        ConvertTime = NewTime
    End If
End Function
Public Function StartUpdate(strURL As String)
    BytesAlreadySent = 1
    If strURL = "" Then Exit Function
    Url = strURL
    Dim Pos%, Length%, NextPos%, LENGTH2%, POS2%, POS3%
        Pos = InStr(strURL, "://") '记录位址 ://
        LENGTH2 = Len("://") '长度
        Length = Len(strURL) '长度
            If InStr(strURL, "://") Then  ' 检查是 http:// 还是 ftp://
            strURL = Right(strURL, Length - LENGTH2 - Pos + 1) '删除 http:// 或 ftp://
            End If
                If InStr(strURL, "/") Then
                POS2 = InStr(strURL, "/")
    '-----------------获取文件名称-------------
                Dim StrFile$: StrFile = strURL
                Do Until InStr(StrFile, "/") = 0
                LENGTH2 = Len(StrFile)
                POS3 = InStr(StrFile, "/") '找标记
                StrFile = Right(strURL, LENGTH2 - POS3)
                Loop
                Filename = StrFile
    '----------------关闭文件--------------
                strSvrURL = Left(strURL, POS2 - 1)
    End If

End Function
Public Sub Reset()
    CloseSocket
    Data = ""
    Percent = 0
    BeginTransfer = 0
    BytesAlreadySent = 0
    BytesRemaining = 0
    Status = ""
    Header = ""
    RESUMEFILE = False
    proProgress.Value = "100"
End Sub
Public Sub CloseSocket()
    Do Until Winsock.State = 0
        Winsock.Close
        Winsock.LocalPort = 0
        Close #1
    Loop
    
End Sub

Private Sub cmdClose_Click()
    Unload Me
    Unload frmUpdate
    Unload frmSave
    Unload frmExist
End Sub

Private Sub cmdDownload_Click()
    StartUpdate txtWebsite.Text
    frmSave.Show
    lblHeader.Visible = False
    aniAnimation.AutoPlay = True
End Sub

Private Sub cmdFinish_Click()
    Const conBtns As Integer = vbYesNoCancel + vbExclamation _
                            + vbDefaultButton3 + vbApplicationModal
    Const conMsg As String = "要现在开始安装吗?"
    Dim intUserResponse As Integer
                  
        intUserResponse = MsgBox(conMsg, conBtns, "在线更新")
        Select Case intUserResponse
            Case vbYes
                OpenIt frmDownload, FilePathName
                Unload Me
                Unload frmMain
                Unload frmSave
                Unload frmExist
            Case vbNo
                Unload Me
                Unload frmMain
                Unload frmSave
                Unload frmExist
            Case vbCancel
        End Select
        
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    CloseSocket
End Sub

Private Sub Form_Unload(Cancel As Integer)
    CloseSocket
End Sub

Private Sub tmrTimeLeft_Timer()
'On Error Resume Next
    If BytesRemaining > 0 And BytesAlreadySent > 0 Then
        If BytesRemaining <= BytesAlreadySent Then
            lblSpeed = 0
            CloseSocket
            lblElapsed = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
            cmdFinish.Enabled = True
            News = (netNews.OpenURL("http://www.mndsoft.com/downfiles/news.txt"))
            rtbNews.Text = News
            lstList.Visible = False
            lblHeader.Caption = "下载完毕"
            MsgBox "下载完毕", vbInformation, "在线更新"
            Reset
        Else
            Sec = Sec + 1
            If Sec >= 60 Then
            Sec = 0
            Min = Min + 1
            ElseIf Min >= 60 Then
            Min = 0
            Hr = Hr + 1
            End If
            cmdFinish.Enabled = False
            lblElapsed = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
            lblRemaining = ConvertTime(Int(((BytesRemaining - BytesAlreadySent) / 1024) / TransferRate))
            lblSpeed = TransferRate
        End If
    
    End If
End Sub

Private Sub tmrUpdateProgress_Timer()
On Error Resume Next
    If BytesAlreadySent > 0 And BytesRemaining > 0 Then
        lblRecieved = File_ByteConversion(BytesAlreadySent)
        lblSize = File_ByteConversion(BytesRemaining)
        Percent = Format((BytesAlreadySent / BytesRemaining) * 1, "00") '计算完成进度
        proProgress.Value = Percent
    End If
End Sub

Private Sub Winsock_Connect()
On Error Resume Next
    Dim strCommand As String
    strCommand = "GET " + Url + " HTTP/1.0" + vbCrLf
    strCommand = strCommand + "Accept: *.*, */*" + vbCrLf
    If RESUMEFILE = True Then
        strCommand = strCommand + "Range: bytes=" & FileLength & "-" & vbCrLf
    End If
    
    strCommand = strCommand + "User-Agent: Online Soft Web.Com" & vbCrLf
    strCommand = strCommand + "Referer: " & strSvrURL & vbCrLf
    strCommand = strCommand + vbCrLf
    Winsock.SendData strCommand
    BeginTransfer = Timer '传输比率的开始时间
    
End Sub

Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
    Winsock.GetData Data, vbString
    If InStr(Data, "Content-Type:") Then
            
            If RESUMEFILE = True Then
                If InStr(Data, "HTTP/1.1 206 Partial Content") = 0 Then
                MsgBox "服务器能接受无法继续.", vbCritical, "错误"
                Exit Sub
                Reset
                CloseSocket
                End If
            End If
            
        Dim Pos%, Length%, HEAD$
        Pos = InStr(Data, vbCrLf & vbCrLf)
        Length = Len(Data)
        HEAD = Left(Data, Pos - 1)
        Data = Right(Data, Length - Pos - 3)
        Header = Header & HEAD
    
        If RESUMEFILE = True Then
            BytesAlreadySent = FileLength + 1
            BytesRemaining = GETDATAHEAD(Header, "Content-Length:")
            BytesRemaining = BytesRemaining + FileLength
        Else
            BytesRemaining = GETDATAHEAD(Header, "Content-Length:")
        End If
        
    End If

'-----------写文件--------
        Open FilePathName For Binary Access Write As #1
        Put #1, BytesAlreadySent, Data
        BytesAlreadySent = Seek(1)
        Close #1
'--------------------------------------------------

    If RESUMEFILE = False Then
        TransferRate = Format(Int(BytesAlreadySent / (Timer - BeginTransfer)) / 1000, "####.00")
    Else
        TransferRate = Format(Int((BytesAlreadySent - FileLength) / (Timer - BeginTransfer)) / 1000, "####.00")
    End If
End Sub

Private Sub tmrStart_Timer()
    StartUpdate txtWebsite.Text
    frmSave.Show
    aniAnimation.AutoPlay = True
    tmrStart.Enabled = False
End Sub