VB 用API下载文件实例

'#############################
'**
'** 文件 frmDownLoad.frm 的内容
'**
'#############################
VERSION 5.00
Begin VB.Form frmDownLoad
BorderStyle = 1 'Fixed Single
Caption = "Form1"
ClientHeight = 2880
ClientLeft = 45
ClientTop = 330
ClientWidth = 6375
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "文件下载"
MaxButton = 0 'False
ScaleHeight = 2880
ScaleWidth = 6375
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton cmdStop
Caption = "停止"
Enabled = 0 'False
Height = 480
Left = 1860
TabIndex = 6
Top = 2160
Width = 1365
End
Begin VB.CommandButton cmdStart
Caption = "开始"
Height = 480
Left = 165
TabIndex = 5
Top = 2160
Width = 1365
End
Begin VB.TextBox txtFile
Height = 330
Left = 750
TabIndex = 3
Top = 705
Width = 5445
End
Begin VB.TextBox txtURL
Height = 330
Left = 750
TabIndex = 1
Top = 285
Width = 5445
End
Begin VB.Label lblCount
BackStyle = 0 'Transparent
Caption = "下载"
Height = 180
Left = 180
TabIndex = 4
Top = 1245
Width = 5130
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "文件:"
Height = 180
Left = 195
TabIndex = 2
Top = 780
Width = 450
End
Begin VB.Label lblURL
AutoSize = -1 'True
Caption = "URL:"
Height = 180
Left = 195
TabIndex = 0
Top = 360
Width = 360
End
End
Attribute VB_Name = "frmDownLoad"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function StrFormatByteSize Lib "shlwapi" Alias _
"StrFormatByteSizeA" (ByVal dw As Long, ByVal pszBuf As String, ByRef _
cchBuf As Long) As String

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 HttpOpenRequest Lib "wininet.dll" _
Alias "HttpOpenRequestA" _
(ByVal hInternetSession As Long, _
ByVal lpszVerb As String, _
ByVal lpszObjectName As String, _
ByVal lpszVersion As String, _
ByVal lpszReferer As String, _
ByVal lpszAcceptTypes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternetSession As Long, _
ByVal lpszServerName As String, _
ByVal nProxyPort As Integer, _
ByVal lpszUsername As String, _
ByVal lpszPassword As String, _
ByVal dwService As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" _
Alias "HttpSendRequestA" _
(ByVal hHttpRequest As Long, _
ByVal sHeaders As String, _
ByVal lHeadersLength As Long, _
ByVal sOptional As String, _
ByVal lOptionalLength As Long) As Boolean

Private Declare Function InternetReadFile Lib "wininet.dll" _
(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 GetLastError Lib "kernel32" () As Long

' Adds one or more HTTP request headers to the HTTP request handle.
'Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" _
'(ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, _
'ByVal lModifiers As Long) As Integer
Private bolStop As Boolean
' 然后，我们可以得到包含了一份详细说明的URL文本文件，它显示在下面的函数中：
Public Function DownloadFile(ByVal surl As String, ByVal strFile As String) As Long
Dim s As String
Dim hOpen As Long
Dim hOpenUrl As Long
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim intFH As Integer

Dim sReadBuffer() As Byte
Dim lNumberOfBytesRead As Long
Dim lCount As Long
Dim myCount As New clsCount
Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PROXY = 3
Const scUserAgent = "VB OpenUrl"
Const INTERNET_FLAG_RELOAD = &H80000000

lblCount.Caption = "正在连接服务器..."
lblCount.Refresh
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, surl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
lCount = 0

If hOpen <> 0 And hOpenUrl <> 0 Then
intFH = FreeFile
If Dir(strFile) <> "" Then
VBA.FileSystem.Kill strFile
End If
Open strFile For Binary As #intFH
myCount.Clear
Do While True
ReDim sReadBuffer(2048)
bRet = InternetReadFile(hOpenUrl, sReadBuffer(0), 2048, lNumberOfBytesRead)
If lNumberOfBytesRead > 0 And bRet = True Then
'if lnumberofbytesread<>2048 then
ReDim Preserve sReadBuffer(0 To lNumberOfBytesRead - 1)
Put #intFH, , sReadBuffer
'
' buf.AddRange sReadBuffer, 0, lNumberOfBytesRead - 1
lCount = lCount + lNumberOfBytesRead
myCount.Count lNumberOfBytesRead
lblCount.Caption = "已下载 " & VBStrFormatByteSize(lCount) & " [ " & VBStrFormatByteSize(myCount.Speed) & " /秒 ]"
lblCount.Refresh
Else
Exit Do
End If
bolStop = False
DoEvents
If bolStop = True Then
Exit Do
End If
Loop
Close #intFH
lblCount.Caption = "共下载 " & lCount & " 字节"
Else
lblCount.Caption = "打开URL错误"
End If

If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
Set myCount = Nothing
DownloadFile = lCount
End Function
Private Sub cmdStart_Click()
txtURL.Enabled = False
txtFile.Enabled = False
cmdStart.Enabled = False
cmdStop.Enabled = True
DownloadFile txtURL.Text, txtFile.Text
cmdStop.Enabled = False
cmdStart.Enabled = True
txtFile.Enabled = True
txtURL.Enabled = True

End Sub
Private Sub cmdStop_Click()
bolStop = True
End Sub
Private Sub SetText(ByVal txt As TextBox)
txt.Text = GetSetting(App.Title, Me.Name, txt.Name)
End Sub
Private Sub SaveText(ByVal txt As TextBox)
SaveSetting App.Title, Me.Name, txt.Name, txt.Text
End Sub
Private Sub Form_Load()
SetText Me.txtFile
SetText Me.txtURL
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveText Me.txtFile
SaveText Me.txtURL
End Sub

Private Function VBStrFormatByteSize(ByVal lngSize As Long) As String
Dim strSize As String * 128
Dim strData As String
Dim lPos As Long
StrFormatByteSize lngSize, strSize, 128
lPos = InStr(1, strSize, Chr$(0))
strData = Left$(strSize, lPos - 1)
If lngSize > 1024 Then
strData = lngSize & "字节(" & strData & ")"
End If
VBStrFormatByteSize = strData
End Function

 

'########################
'**
'** 文件 clsCount.cls 的内容
'**
'########################
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsCount"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'******************************************************************************
'**
'** 用于计算速度的类模块
'**
'** 该类模块设定一个计数器,由程序不断的累计数据,并根据所花时间计算数据
'**
'** 编制: 袁永福
'** 时间: 2002-4-2
'**
'******************************************************************************
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private lngCountStart As Long
Private lngCountCurrent As Long
Private lngCountLast As Long
Private lngSpeed As Long
Private lngTickStart As Long
Private lngTickCurrent As Long
Private lngTickLast As Long
'Public StopCount As Boolean
'** 获得计数数据 **************************************************************
'** 累计初始值
Public Property Get CountStart() As Long
CountStart = lngCountStart
End Property
'** 累计终止值
Public Property Get CountEnd() As Long
CountEnd = lngCountCurrent
End Property
'** 累计总的速度
Public Property Get TotalSpeed() As Long
If lngTickCurrent = lngTickStart Then
TotalSpeed = 0
Else
TotalSpeed = (lngCountCurrent - lngCountStart) / ((lngTickCurrent - lngTickStart) / 1000)
End If
End Property
'** 累计所花毫秒数
Public Property Get TotalTickCount() As Long
TotalTickCount = lngTickCurrent - lngTickStart
End Property
'** 清除所有数据 **************************************************************
Public Sub Clear()
lngCountStart = 0
lngCountCurrent = 0
lngCountLast = 0

lngSpeed = 0

lngTickStart = GetTickCount()
lngTickCurrent = lngTickStart
lngTickLast = lngTickStart

'StopCount = False
End Sub
'** 设置累计基数
Public Property Let CountStart(ByVal lStart As Long)
lngCountStart = lStart
lngCountCurrent = lStart
End Property
'** 累加数据 **
Public Sub Count(Optional ByVal lCount As Long = 1)
lngCountCurrent = lngCountCurrent + lCount
lngTickCurrent = GetTickCount()
End Sub

'** 获得速度 **
Public Property Get Speed() As Long
'lngTickCurrent = GetTickCount()
If lngTickLast = lngTickCurrent Then
Speed = lngSpeed
Else
Speed = (lngCountCurrent - lngCountLast) / ((lngTickCurrent - lngTickLast) / 1000)
lngSpeed = Speed
lngTickLast = lngTickCurrent
lngCountLast = lngCountCurrent
End If
End Property

'** 数据是否是最新更新的 **
Public Property Get NewSpeed() As Boolean
Dim bolNew As Boolean
If lngTickCurrent > lngTickLast + 1000 Then
bolNew = True
Else
bolNew = False
End If
NewSpeed = bolNew
End Property