📄 form1.frm
字号:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1
Caption = "文件下载"
ClientHeight = 5430
ClientLeft = 60
ClientTop = 345
ClientWidth = 4125
LinkTopic = "Form1"
ScaleHeight = 5430
ScaleWidth = 4125
StartUpPosition = 3 '窗口缺省
Begin VB.Timer Timer2
Interval = 1000
Left = 840
Top = 2880
End
Begin VB.Timer Timer1
Interval = 1
Left = 120
Top = 2880
End
Begin MSWinsockLib.Winsock Winsock
Left = 960
Top = 2400
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.TextBox TxtHead
Height = 2055
Left = 0
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 18
Text = "Form1.frx":0000
Top = 3240
Width = 4095
End
Begin VB.PictureBox Picture1
Height = 1455
Left = 1440
ScaleHeight = 1395
ScaleWidth = 2355
TabIndex = 11
Top = 1560
Width = 2415
Begin VB.Label LabelEtm
AutoSize = -1 'True
Caption = "LabelEtm"
Height = 180
Left = 120
TabIndex = 17
Top = 1200
Width = 720
End
Begin VB.Label LabelGtm
AutoSize = -1 'True
Caption = "LabelGtm"
Height = 180
Left = 120
TabIndex = 16
Top = 960
Width = 720
End
Begin VB.Label LabelSpe
AutoSize = -1 'True
Caption = "LabelSpe"
Height = 180
Left = 120
TabIndex = 15
Top = 720
Width = 720
End
Begin VB.Label LabelPer
AutoSize = -1 'True
Caption = "LabelPer"
Height = 180
Left = 120
TabIndex = 14
Top = 480
Width = 720
End
Begin VB.Label LabelGot
AutoSize = -1 'True
Caption = "LabelGot"
Height = 180
Left = 120
TabIndex = 13
Top = 240
Width = 720
End
Begin VB.Label LabelSize
AutoSize = -1 'True
Caption = "LabelSize"
Height = 180
Left = 120
TabIndex = 12
Top = 0
Width = 810
End
End
Begin VB.CommandButton Command3
Caption = "停止下载"
Height = 495
Left = 2760
TabIndex = 4
Top = 960
Width = 1335
End
Begin VB.CommandButton Command2
Caption = "暂停下载"
Height = 495
Left = 1320
TabIndex = 3
Top = 960
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "开始下载"
Height = 495
Left = 0
TabIndex = 1
Top = 960
Width = 1215
End
Begin VB.TextBox TxtUrl
Height = 375
Left = 0
TabIndex = 0
Text = "Text1"
Top = 480
Width = 4095
End
Begin VB.Label Label7
AutoSize = -1 'True
Caption = "剩余时间："
Height = 180
Left = 0
TabIndex = 10
Top = 2760
Width = 900
End
Begin VB.Label Label6
AutoSize = -1 'True
Caption = "已用时间："
Height = 180
Left = 0
TabIndex = 9
Top = 2520
Width = 900
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "下载速率："
Height = 180
Left = 0
TabIndex = 8
Top = 2280
Width = 900
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "得到的百分比："
Height = 180
Left = 0
TabIndex = 7
Top = 2040
Width = 1260
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "已经得到的大小："
Height = 180
Left = 0
TabIndex = 6
Top = 1800
Width = 1440
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "文件大小："
Height = 180
Left = 0
TabIndex = 5
Top = 1560
Width = 900
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "下载路径和文件名："
Height = 180
Left = 0
TabIndex = 2
Top = 120
Width = 1620
End
End
Attribute VB_Name = "Form1"
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
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
strURL = Right(strURL, LENGTH - LENGTH2 - Pos + 1)
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) 'removes everything after the / mark leaving just the server name as the end result
End If
Winsock.Connect strSvrURL, 80
FilePathName = "C:\" & FileName
End Function
Public Sub CloseSocket()
'关闭Socket
Do Until Winsock.State = 0
Winsock.Close
Winsock.LocalPort = 0
Close #1
Loop
End Sub
Public Sub Reset()
'重置
CloseSocket
DATA = ""
Percent = 0
BeginTransfer = 0
BytesAlreadySent = 1
BytesRemaining = 0
Status = ""
Header = ""
RESUMEFILE = False
Command1.Enabled = True
End Sub
Private Sub Command1_Click()
FilePath = InputBox("请输入要保存到的路径：", "SaveTo", "c:\")
StartUpdate TxtUrl
FilePathName = FilePath & FileName
End Sub
Private Sub Command2_Click()
If BytesRemaining > BytesAlreadySent Then
If Winsock.State > 0 Then
DATA = ""
BeginTransfer = 0
Status = ""
Header = ""
CloseSocket
Else
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
Reset
End If
End Sub
Private Sub Form_Load()
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
If BytesRemaining > 0 And BytesAlreadySent > 0 Then
If BytesRemaining <= BytesAlreadySent Then
LabelSpe = 0
CloseSocket
LabelEtm = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
Command1.Enabled = False
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
LabelGtm = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
LabelEtm = ConvertTime(Int(((BytesRemaining - BytesAlreadySent) / 1024) / TransferRate))
LabelSpe = TransferRate
End If
End If
End Sub
Private Sub Timer2_Timer()
On Error Resume Next
If BytesRemaining > 0 And BytesAlreadySent > 0 Then
If BytesRemaining <= BytesAlreadySent Then
LabelSpe = 0
CloseSocket
LabelGtm = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
Command1.Enabled = False
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
LabelGtm = Format(Hr & ":" & Min & ":" & Sec, "HH:MM:SS")
LabelEtm = ConvertTime(Int(((BytesRemaining - BytesAlreadySent) / 1024) / TransferRate))
LabelSpe = TransferRate
End If
End If
End Sub
Private Sub Winsock1_Connect()
Dim strCommand As String
On Error Resume Next
If Not Unix Then
strCommand = "GET " + URL + " HTTP/1.0" + vbCrLf
Else
strCommand = "GET " + "/" + FileName + " HTTP/1.0" + vbCrLf
End If
strCommand = strCommand + "Accept: *.*, */*" + vbCrLf
If RESUMEFILE = True Then strCommand = strCommand + "Range: bytes=" & FileLength & "-" & vbCrLf
strCommand = strCommand + "User-Agent: Conquest" & vbCrLf
If Not Unix Then
strCommand = strCommand + "Referer: " & strSvrURL & vbCrLf
Else
strCommand = strCommand + "Host: " & strSvrURL & vbCrLf
End If
strCommand = strCommand + vbCrLf
Winsock.SendData strCommand
BeginTransfer = Timer
End Sub
Private Sub Winsock1_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, "No Resuming Support"
Exit Sub
Reset
CloseSocket
End If
End If
If InStr(DATA, "404 Not Found") > 0 Then
If Not Unix Then
Unix = True
Reset
CloseSocket
Main.Winsock.Connect strSvrURL, 80
Exit Sub
End If
Unix = False
MsgBox "服务器上没有这个文件！", vbCritical, "File Not Found"
Reset
CloseSocket
Exit Sub
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
TxtHead = Header
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -