| zVerb 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 <> 上一页 [1] [2] [3] [4] 下一页 |
