I have created a usercontrol similar to the VB Asycdownload usercontrol and it works, but i thought i had the cancel
downloads working but i dont. I cannot figure out if i start 6 downloads, i would like to cancel all downloads.
Sometimes the VBAscyncdownload does not work with some pages or downloads so tried to make something that works the same.
Please not that sometimes i create and array of the usercontrol so would need usercontrol(x).Canceldownload
can someone a bit smarter help me please. tks
code below is placed on a usercontrol.
downloads working but i dont. I cannot figure out if i start 6 downloads, i would like to cancel all downloads.
Sometimes the VBAscyncdownload does not work with some pages or downloads so tried to make something that works the same.
Please not that sometimes i create and array of the usercontrol so would need usercontrol(x).Canceldownload
can someone a bit smarter help me please. tks
code below is placed on a usercontrol.
Code:
'status code for getting the page successfully.
Private Const HttpStatusOK200 As Integer = 200
'status code for not getting the page
Private Const HttpFileNotFound404 As Integer = 404
'status code for request timed out.
Private Const HttpTimeOutError12002 As Integer = 12002
Private WithEvents http As WinHttpRequest
Private FF As Integer
Private mContentLength As Long
Private mProgress As Long
Dim strLocalFile As String
Dim Cancel_Download As Boolean
Public Event Progress(percent As Single)
Public Event Zero()
Public Event Finished(LocalFile As String)
Public Event PageDownloadComplete(Data As String)
Public CurrentDownloads As New Collection
Public Sub CancelDownload()
http.Abort
Close #FF
Kill strLocalFile
RaiseEvent Progress(0)
CurrentDownloads.Remove 1
RefreshStatus
End Sub
Public Sub GetWebData(ByVal URL As String)
On Error GoTo err
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objHTTP.Open "GET", URL, True
objHTTP.SetRequestHeader "Authorization", "Bearer " & "" ' AuthCode
objHTTP.SetRequestHeader "Accept-Language", "en"
objHTTP.sEnd
Do While objHTTP.ReadyState <> 4
If objHTTP.ReadyState = HttpTimeOutError12002 Then
ElseIf objHTTP.ReadyState = HttpFileNotFound404 Then
End If
DoEvents
Loop
RaiseEvent PageDownloadComplete(objHTTP.ResponseText)
Set objHTTP = Nothing
Exit Sub
err:
End Sub
Public Sub DownloadBinary(ByVal BinaryURL As String, ByVal LocalFile As String)
strLocalFile = LocalFile
' Create the WinHTTPRequest ActiveX Object.
Set http = New WinHttpRequest
' Open an HTTP connection.
http.Open "GET", BinaryURL, True 'True means asynch.
' Send the HTTP Request.
http.sEnd
CurrentDownloads.Add BinaryURL, BinaryURL
RefreshStatus
End Sub
Private Sub http_OnResponseDataAvailable(Data() As Byte)
mProgress = mProgress + UBound(Data) + 1
RaiseEvent Progress(Format((mProgress / mContentLength) * 100, "00"))
Put #FF, , Data
End Sub
Private Sub http_OnResponseFinished()
Close #FF
RaiseEvent Finished(strLocalFile)
On Error Resume Next
CurrentDownloads.Remove 1
RefreshStatus
On Error GoTo 0
End Sub
Private Sub http_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
'Text1.Text = http.getAllResponseHeaders()
mProgress = 0
mContentLength = CLng(http.GetResponseHeader("Content-Length"))
FF = FreeFile
'ProgressBar1.Max = mContentLength
Open strLocalFile For Binary As #FF
End Sub
Private Sub UserControl_Resize()
UserControl.Width = 960
UserControl.Height = 960
End Sub
Private Sub RefreshStatus()
UserControl.Cls
UserControl.CurrentX = 0
UserControl.CurrentY = 0
UserControl.Print CurrentDownloads.Count
If CurrentDownloads.Count = 0 Then
RaiseEvent Zero
End If
End Sub