1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
Option Explicit
dim bSuivant as boolean 'BIT DE SYNCHRO ... PASSAGE FICHIER SUIVANT
'downloads an (binary)file over the HTTP-protocol and saves it to a file
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) 'used for direct memory copy
Const Timeout As Long = 60 'Timeout, if no connection can be established (in seconds)
Dim file() As Byte, Destination As String 'Byte-Array containing current file-contents; Destination file on the harddisk
Dim LastSizeCheck As Long, LastSize As Long 'Data needed for speed-status
Private Sub btnStartDL_Click()
Dim index As Integer
Dim tableau(1 To 5) As String
tableau(1) = "0139-TOM-13:34:58"
tableau(2) = "0139-PQR-13:03:16"
tableau(3) = "0137-JOHN-16:00:50"
tableau(4) = "0137-BOB-15:56:55"
tableau(5) = "0137-BOB-15:41:48"
For index = 1 To 5
bSuivant = false
Inet1.RequestTimeout = Timeout 'set timeout
ProgressBar1.Max = 1024 '--- here you must fill in the expected file size (in KBs), for using the progressbar...
Destination = App.Path & "\file" & index & ".html" 'set destination file
Label1.Caption = "Establishing connection..."
Inet1.Execute "http://10.101.55.95/cgi-bin/ProcSummary?VIEW&" & tableau(index), "GET" 'Start the download of the specified file
Next index
While NOt bSuivant 'Attente passage fichier suivant..
DoEvents
Wend
End Sub
'Determines the UBound of the "file"-Array. If the Array is "Empty" ("Erase file"), it returns -1
Private Function SafeUBoundFile() As Long
On Error GoTo erro
SafeUBoundFile = UBound(file)
Exit Function
erro:
SafeUBoundFile = -1
End Function
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Inet1.Cancel 'cancel on exit
End Sub
Private Sub INet1_StateChanged(ByVal State As Integer)
Static inProc As Boolean
If Not inProc Then 'only execute this procedure, if it is the first call (DoEvents in this sub may call this event frequently
inProc = True
Debug.Print Timer, State
Select Case State
Case icResponseReceived 'Received something
Dim vtData() As Byte 'Current Chunk
Label1.Caption = "Downloading " & Inet1.URL & "..."
Do While Inet1.StillExecuting
DoEvents
Loop
Do
DoEvents
vtData = Inet1.GetChunk(256, 1)
If UBound(vtData) = -1 Then Exit Do 'exit loop, if no Chunk could received
ReDim Preserve file(SafeUBoundFile + UBound(vtData) + 1) 'enlarge file-array
CopyMemory file(UBound(file) - UBound(vtData)), vtData(0), UBound(vtData) + 1 'copy received Chunk to the file-array
If UBound(vtData) <> 255 Then Exit Do 'if the length of the chunk is not 255, then it must be the last chunk of the file
Dim tmp As Long
tmp = UBound(file) / 1024
If tmp > ProgressBar1.Max Then tmp = ProgressBar1.Max 'if KBs is higher then ProgressBar1.Maxy then truncated
ProgressBar1.Value = tmp 'update ProgressBar1
Loop
Label1.Caption = "Download complete."
MsgBox "Download complete."
Inet1.Cancel
Open Destination For Binary As #1 'Write file-array to destination-file
Put #1, , file
Close #1
Erase file 'free file-array
End Select
inProc = False
End If
bSuivant = true 'AUTORISE PASSAGE FICHIER SUIVANT
End Sub
'Updates the status. Think about it....
Private Sub Timer1_Timer()
Label2.Caption = Format(SafeUBoundFile / 1024, "#,##0.00 KB") & " @ " & _
Format((SafeUBoundFile - LastSize) / 1024 / (Timer - LastSizeCheck / 1000), "#,##0.00 KB/s")
LastSizeCheck = Timer * 1000
LastSize = SafeUBoundFile
End Sub |
Télécharger pages Web
Répondre avec citation
Envoyé par shomacdo
Partager