main.frm

完整的下载程序

      AutoSize        =   -1  'True
      Caption         =   "Enter the url in which the file is located:"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   0
      TabIndex        =   5
      Top             =   0
      Width           =   2835
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu showheader 
         Caption         =   "&Show Header"
      End
      Begin VB.Menu Line1 
         Caption         =   "-"
      End
      Begin VB.Menu exit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuAbout 
      Caption         =   "&About"
      Begin VB.Menu aboutdownloader 
         Caption         =   "&About Downloader"
      End
      Begin VB.Menu ElucidOnWeb 
         Caption         =   "&Elucid Software Webpage"
      End
   End
End
Attribute VB_Name = "Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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 TimeLeft As String
'Dim TimerVal As Single


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, "://") 'Record position of ://
    LENGTH2 = Len("://") 'Record the length of it
    Length = Len(strURL) 'Length of the entire url
        If InStr(strURL, "://") Then  ' check if they entered the http:// or ftp://
        strURL = Right(strURL, Length - LENGTH2 - Pos + 1) ' remove http:// or ftp://
        End If
            If InStr(strURL, "/") Then 'looks for the first / mark going from left to right
            POS2 = InStr(strURL, "/") 'gets the position of the / mark
'-----------------GET THE FILENAME-------------
            Dim StrFile$: StrFile = strURL 'load the variables into each other
            Do Until InStr(StrFile, "/") = 0 'Do the loop until all is left is the filename
            LENGTH2 = Len(StrFile) 'get the length of the filename every time its passed over by the loop
            POS3 = InStr(StrFile, "/") 'find the / mark
            StrFile = Right(strURL, LENGTH2 - POS3) 'slash it down removing everything before the / mark including the / mark...
            Loop
            Filename = StrFile
'----------------END GET FILE NAME--------------
            strSvrURL = Left(strURL, POS2 - 1) 'removes everything after the / mark leaving just the server name as the end result
            End If
'-----------END TRIM THE URL FOR THE SERVER NAME-----------

End Function
Public Sub Reset()
CloseSocket
DATA = ""
Percent = 0
BeginTransfer = 0
BytesAlreadySent = 0
BytesRemaining = 0
Status = ""
Header = ""
RESUMEFILE = False
UpdateProgress Picture1, 0
Command1.Enabled = True
End Sub
Public Sub CloseSocket()
Do Until Winsock.State = 0
Winsock.Close
Winsock.LocalPort = 0
Close #1
Loop
End Sub

Private Sub aboutdownloader_Click()
frmAbout.Show
End Sub

Private Sub cmdRun_Click()
OpenIt Me, FilePathName
End Sub

Private Sub Command1_Click()
StartUpdate Text1
frmSave.Show
lblStatus.Visible = False
Picture1.Visible = True
End Sub

Private Sub Command2_Click()
If BytesRemaining > BytesAlreadySent Then
If Winsock.State > 0 Then
DATA = ""
BeginTransfer = 0
Status = ""
Header = ""
CloseSocket
Picture1.Visible = False
lblStatus.Visible = True
lblStatus.Caption = "Download Paused"
Else
Picture1.Visible = True
lblStatus.Visible = False
FileLength = FileLen(FilePathName)
RESUMEFILE = True
Main.Winsock.Connect strSvrURL, 80
End If

End If
End Sub

Private Sub Command3_Click()
If Winsock.State > 0 Then
CloseSocket
MsgBox "Transfer Aborted!", vbExclamation, "Aborted"
Reset
End If
End Sub

Private Sub ElucidOnWeb_Click()
OpenIt Me, "http://elucidsoftware.hypermart.net"
End Sub

Private Sub exit_Click()
Unload Me
End Sub

Private Sub Form_Load()
Me.Height = 3150
RESUMEFILE = False
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 Progtmr_Timer()
End Sub

Private Sub showheader_Click()
If Me.Height = 5940 Then
Me.Height = 3150
Else
Me.Height = 5940
End If
End Sub

Private Sub Timer1_Timer()

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")
Command1.Enabled = False
cmdRun.Enabled = True
Picture1.Visible = False
lblStatus.Visible = True
lblStatus.Caption = "Download Completed"
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
Command1.Enabled = True
cmdRun.Enabled = False
lblElapsed = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
'The reason I divide the difference of bytesalreadysent and bytesremaining is becuase they are in bytes right now.. I want it to be in KB so it can be Kbps and not bps
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
lblRecieve = File_ByteConversion(BytesAlreadySent)
lblSize = File_ByteConversion(BytesRemaining)
Percent = Format((BytesAlreadySent / BytesRemaining) * 100, "00") 'calculates the percentage completed
UpdateProgress Picture1, Percent 'updates progress bar with new percentage rate
End If
End Sub

Private Sub Winsock_Close()
FormsOnTop Me, False
End Sub

Private Sub Winsock_Connect()
On Error Resume Next
Dim strCommand As String
strCommand = "GET " + URL + " HTTP/1.0" + vbCrLf 'tells server to GET the file if you just want the header info and not the data change "GET " to "HEAD "
strCommand = strCommand + "Accept: *.*, */*" + vbCrLf
If RESUMEFILE = True Then strCommand = strCommand + "Range: bytes=" & FileLength & "-" & vbCrLf
strCommand = strCommand + "User-Agent: Elucid Software Downloader" & vbCrLf
strCommand = strCommand + "Referer: " & strSvrURL & vbCrLf
strCommand = strCommand + vbCrLf
Winsock.SendData strCommand 'sends a header to the server instructing it what to do!
BeginTransfer = Timer 'start timer for transfer rate
End Sub

Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
Winsock.GetData DATA, vbString
If InStr(DATA, "Content-Type:") Then 'find out if this chunk has the header..you can change that to anything that the header contains
        
        If RESUMEFILE = True Then 'check to see if its gonna resume ok or not..This is actually the worst way to check this.
            If InStr(DATA, "HTTP/1.1 206 Partial Content") = 0 Then
            MsgBox "Server did not accept resuming.", vbCritical, "No Resuming Support"
            Exit Sub
            Reset
            CloseSocket
            End If
        End If
        
    Dim Pos%, Length%, HEAD$
    Pos = InStr(DATA, vbCrLf & vbCrLf) ' find out where the header and the data is split apart
    Length = Len(DATA) 'get the length of the data chunk
    HEAD = Left(DATA, Pos - 1) 'Get the header from the chunk of data and ignore the data content
    DATA = Right(DATA, Length - Pos - 3) 'Get the data from the first chunk that contains the header also
    Header = Header & HEAD 'Append the header to header text box

If RESUMEFILE = True Then
BytesAlreadySent = FileLength + 1
BytesRemaining = GETDATAHEAD(Header, "Content-Length:")
BytesRemaining = BytesRemaining + FileLength
Else
BytesRemaining = GETDATAHEAD(Header, "Content-Length:")
End If
txtHead = Header
End If

'-----------BEGIN WRITE CHUNK TO FILE CODE--------
        Open FilePathName For Binary Access Write As #1 'opens file for output
        Put #1, BytesAlreadySent, DATA 'writes data to the end of file
        BytesAlreadySent = Seek(1)
        Close #1 'close file for now until next data chunk is available
'--------------------------------------------------

'Lets explain this a bit..The variable BeginTransfer is given the starting value of the
'timer which in case you dont know is the amount of seconds til midnight but that has
'nothing to do with this. Anyways so its given the amount for the start time and then
'when this event below is fired for the first time the timer will be given the value again
'since your system clock was ticking along while the operation between the two of these
'events happened the number will be different.  The two values are subtracted and divided
'by the amount recieved and then by 1000 and put into a readable format
If RESUMEFILE = False Then
'This is pretty straightforward if you ever taken math before you can tell what im doing!
TransferRate = Format(Int(BytesAlreadySent / (Timer - BeginTransfer)) / 1000, "####.00")
Else
'If you dont subtract the difference you will get a really large and odd download speed hehe.
TransferRate = Format(Int((BytesAlreadySent - FileLength) / (Timer - BeginTransfer)) / 1000, "####.00")
End If
End Sub