'窗体
Private WithEvents Cdf As Cls_DownLoad
Private Sub Form_Load()
Set Cdf = New Cls_DownLoad
End Sub
Private Sub Cdf_entDLFileDowning(sRemoteURL As String, lDownLoaded As Long, lFilesize As Long, lSpeed As Long)
Dim sTmp$, lTmp&
If lSpeed = 0 Then lSpeed = 10
If lFilesize > 0 Then lTmp = (lDownLoaded / lFilesize * 100)
sTmp = "下载进度： " & Format(lTmp, "0.0") & " %"
sTmp = sTmp & vbCrLf & "图片大小： " & lFilesize / 1024
sTmp = sTmp & vbCrLf & "下载大小： " & lDownLoaded / 1024
sTmp = sTmp & vbCrLf & "下载速度： " & lSpeed / 1024
'Label4 = sTmp
End Sub
Private Sub Cdf_entDLFileStatus(TmpState As eDL_Status)
Select Case TmpState
Case 1
sConnectStauts = "连接服务器..."
Case 2
sConnectStauts = "发送请求..."
Case 3
sConnectStauts = "获取远程文件信息..."
Case 4
sConnectStauts = "下载数据..."
Case 5
sConnectStauts = "停止下载"
Case 6
sConnectStauts = "下载完成"
Case 7
sConnectStauts = "连接服务器失败"
Case 8
sConnectStauts = "发送请求失败"
Case 9
sConnectStauts = "连接服务器"
Case Else
sConnectStauts = "下载被中止"
End Select
'Label5 = "连接状态： " & sConnectStauts
End Sub
Sub Cdf_DownLoad(Link as string , File as string)
If Cdf.DLFile(Link,File, 5 * 1000) Then '超时5秒
End If
End Sub
Private Sub Cdf_DownLoad_Stop()
Cdf.DLFileStop '停止下载
End Sub
'----------------------------------------------------
'模块
'名称 CdfDownLoadMould
Public Cdf As New Cls_DownLoad
'----------------------------------------------------
'类模块
'名称 Cls_DownLoad
Option Explicit
'(DLFile)
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal surl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetReadFileByte Lib "wininet.dll" Alias "InternetReadFile" (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_FLAG_RELOAD = &H80000000
Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Const HTTP_QUERY_CONTENT_LENGTH = 5
Const scUserAgent = "VB Http"
Const BufferSizeA& = 512
Const BufferSizeP& = 512
Public Event entDLFileDowning(sRemoteURL$, lDownLoaded&, lFilesize&, lSpeed&)
Public Event entDLFileStatus(TmpState As eDL_Status)
Public Enum eDL_Status
s1 = 1 ' 连接服务器
s2 = 2 ' 发送请求
s3 = 3 ' 获取远程文件信息
s4 = 4 ' 开始接收数据
s5 = 5 ' 停止下载
s6 = 6 ' 下载完成
e1 = 7 ' 连接服务器失败
e2 = 8 ' 发送请求失败
e3 = 9 ' 下载被中止
End Enum
Private bolStop As Boolean
'#####################################################################################################################################
'(DLFile)
'**************************************************************************************
Public Function DLFile&(sRemoteURL$, sLocalFilePath$, Optional lTimeOut& = 5000)
Dim hInternetOpen&, hInternetOpenUrl&, hHttpQueryInfo&, StartTime&, TimeConsuming&, lSpeed&, _
sBuffer As String * BufferSizeA, lNumberOfBytesRead&, Flng%, TotalReadSize&, bRet&, ReadBuffer() As Byte
RaiseEvent entDLFileStatus(s1)
hInternetOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If hInternetOpen Then
RaiseEvent entDLFileStatus(s2)
hInternetOpenUrl = InternetOpenUrl(hInternetOpen, sRemoteURL, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
If hInternetOpenUrl Then
RaiseEvent entDLFileStatus(s3)
hHttpQueryInfo = HttpQueryInfo(hInternetOpenUrl, HTTP_QUERY_CONTENT_LENGTH, ByVal sBuffer, Len(sBuffer), 0)
sBuffer = IIf(hHttpQueryInfo, Left(sBuffer, Len(sBuffer)), "0")
ReDim ReadBuffer(BufferSizeA)
StartTime = Timer
Flng = FreeFile
RaiseEvent entDLFileStatus(s4)
Open sLocalFilePath For Binary Access Write Lock Read As #Flng
Do
bRet = InternetReadFileByte(hInternetOpenUrl, ReadBuffer(0), BufferSizeA, lNumberOfBytesRead)
If bRet And lNumberOfBytesRead > 0 Then
ReDim Preserve ReadBuffer(0 To lNumberOfBytesRead - 1)
Put #Flng, , ReadBuffer
TotalReadSize = TotalReadSize + lNumberOfBytesRead
TimeConsuming = Timer - StartTime
If TimeConsuming > 0 Then
lSpeed = TotalReadSize / TimeConsuming
Else
lSpeed = 1025
End If
RaiseEvent entDLFileDowning(sRemoteURL, TotalReadSize, CLng(sBuffer), lSpeed)
Else
RaiseEvent entDLFileStatus(e3)
Exit Do
End If
If bolStop Then
bolStop = False
RaiseEvent entDLFileStatus(s5)
Exit Do
End If
DoEvents
Loop
Close #Flng
Erase ReadBuffer
InternetCloseHandle hInternetOpenUrl
Else
RaiseEvent entDLFileStatus(e2)
End If
InternetCloseHandle hInternetOpen
RaiseEvent entDLFileStatus(s6)
DLFile = TotalReadSize
Else
RaiseEvent entDLFileStatus(e1)
End If
End Function
Public Function DLFileStop() As Boolean
bolStop = True
End Function
