'#############################
'**
'** 文件 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