用vb开发实现http文件下载的ActiveX控件
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
On Error Resume Next
Dim f() As Byte, fn As Long
If AsyncProp.BytesMax <> 0 Then
fn = FreeFile
f = AsyncProp.Value
Open AsyncProp.PropertyName For Binary Access Write As #fn
Put #fn, , f
Close #fn
Else
RaiseEvent DownloadError(AsyncProp.PropertyName)
End If
RaiseEvent DownloadComplete(CLng(AsyncProp.BytesMax), AsyncProp.PropertyName)
downStat = False
End Sub
Private Sub UserControl_AsyncReadProgress(AsyncProp As AsyncProperty)
On Error Resume Next
If AsyncProp.BytesMax <> 0 Then
RaiseEvent DownloadProgress(CLng(AsyncProp.BytesRead), CLng(AsyncProp.BytesMax), AsyncProp.PropertyName)
downStat = True
': Timer1.Enabled = True
End If
End Sub
'Private Sub UserControl_Resize()
' SizeIt
'End Sub
Public Sub BeginDownload(url As String, SaveFileDir As String, SaveFileName As String)
downStat = True
On Error Resume Next
Dim fs As New FileSystemObject
If (Not fs.FolderExists(SaveFileDir)) Then
MkDir SaveFileDir
End If
On Error GoTo ErrorBeginDownload
UserControl.AsyncRead url, vbAsyncTypeByteArray, SaveFileDir & SaveFileName, vbAsyncReadForceUpdate
'Timer1.Enabled = True
Exit Sub
ErrorBeginDownload:
downStat = False
MsgBox Err & "开始下载数据失败!" _
& vbCrLf & vbCrLf & "错误:" & Err.Description, vbCritical, "错误"
End Sub
On Error Resume Next
Dim f() As Byte, fn As Long
If AsyncProp.BytesMax <> 0 Then
fn = FreeFile
f = AsyncProp.Value
Open AsyncProp.PropertyName For Binary Access Write As #fn
Put #fn, , f
Close #fn
Else
RaiseEvent DownloadError(AsyncProp.PropertyName)
End If
RaiseEvent DownloadComplete(CLng(AsyncProp.BytesMax), AsyncProp.PropertyName)
downStat = False
End Sub
Private Sub UserControl_AsyncReadProgress(AsyncProp As AsyncProperty)
On Error Resume Next
If AsyncProp.BytesMax <> 0 Then
RaiseEvent DownloadProgress(CLng(AsyncProp.BytesRead), CLng(AsyncProp.BytesMax), AsyncProp.PropertyName)
downStat = True
': Timer1.Enabled = True
End If
End Sub
'Private Sub UserControl_Resize()
' SizeIt
'End Sub
Public Sub BeginDownload(url As String, SaveFileDir As String, SaveFileName As String)
downStat = True
On Error Resume Next
Dim fs As New FileSystemObject
If (Not fs.FolderExists(SaveFileDir)) Then
MkDir SaveFileDir
End If
On Error GoTo ErrorBeginDownload
UserControl.AsyncRead url, vbAsyncTypeByteArray, SaveFileDir & SaveFileName, vbAsyncReadForceUpdate
'Timer1.Enabled = True
Exit Sub
ErrorBeginDownload:
downStat = False
MsgBox Err & "开始下载数据失败!" _
& vbCrLf & vbCrLf & "错误:" & Err.Description, vbCritical, "错误"
End Sub