当前位置:编程学习 > VB >>

如何用VB做下载工具

请给出代码和说明要用到什么控件.
追问:你这种是利用浏览器自带的,那如果不是浏览器自带的那种,会不会很难啊

答案:二个按钮 一个文本用来输入下载地址的
Private Declare Function DoFileDownload Lib "shdocvw.dll" _
(ByVal lpszFile As String) As Long

Private Sub Form_Load()
Text1.Text = " http://www.mingrisoft.com"
End Sub

Private Sub Command1_Click() '下载
Dim sDownload As String
sDownload = StrConv(Text1.Text, vbUnicode)
Call DoFileDownload(sDownload)
End Sub

Private Sub Command2_Click()
End
End Sub

窗体1

Option Explicit
Dim WithEvents tg As DownLoad
Dim tmp As Long

Private Sub Command1_Click()

Command1.Enabled = False
tg.URL = T1 '设置下载地址
tg.SaveFile = T2 '下载后的文件存放位置
tg.Execute '连接网络
tmp = CLng(tg.GetHeader("Content-Length")) '获取下载文件大小
tg.StartDownLoad '开始下载
Command1.Enabled = True

End Sub

Private Sub Command2_Click()

tg.Cancel

End Sub

Private Sub Form_Load()

Set tg = New DownLoad
T1 = " http://wo196157629.gicp.net/lz/社区管理系统.exe"
T2 = App.Path & "\setup.exe"
Command1.Caption = "下载1"
Command3.Caption = "停止1"

End Sub

Private Sub tg_DownLoadOver()
MsgBox "下载成功!", vbInformation, "提示"
End Sub

Private Sub tg_ErrMassage(Description As String)
'错误信息
MsgBox Description, vbCritical, "错误"

End Sub

Private Sub tg_GetData(Progress As Long)
'Progress返回的是已下载的数据大小
L = Format$(Progress, "###,###") & "/" & Format$(tmp, "###,###")

End Sub


类模块 名 DownLoad


Option Explicit
Private Declare Function InternetOpen Lib "wininet" 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 InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, sBuffer As Byte, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByVal sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const scUserAgent = "Tgwang"
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private mvarUrl As String
Private mvarSaveFile As String
Private mvarConnect As Boolean
Private hOpen As Long, hFile As Long
Private Buffer As String, BufLen As Long
Private RetQueryInfo As Boolean
Public Event GetData(Progress As Long) '下载进度
Public Event ErrMassage(Description As String) '错误信息
Public Event DownLoadOver()
Public Sub Execute()

mvarConnect = True

hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)

If mvarConnect = False Then
Cancel
Exit Sub
End If

If hOpen = 0 Then
Cancel
RaiseEvent ErrMassage("无法创建连接")
mvarConnect = False
Else

hFile = InternetOpenUrl(hOpen, mvarUrl, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)

If mvarConnect = False Then
Cancel
Exit Sub
End If

If hFile = 0 Then
Cancel
RaiseEvent ErrMassage("无法连接服务器")
mvarConnect = False
Else
Buffer = Space$(1024)
BufLen = 1024
RetQueryInfo = HttpQueryInfo(hFile, 21, Buffer, BufLen, 0)

If RetQueryInfo Then
Buffer = Mid$(Buffer, 1, BufLen)
Else
Buffer = ""
End If

End If

End If

End Sub

'Public Function FileSize() As Long

' FileSize = GetHeader("Content-Length")

'End Function

Public Function StartDownLoad() As Boolean

Dim sBuffer(1 To 1024) As Byte, Ret As Long
Dim intfile As Long, LBR As Long
Dim i As Long

If mvarConnect = False Then
Cancel
StartDownLoad = False
Exit Function
End If

On Error GoTo OutErr
Err.Clear
'If Dir$(mvarSaveFile) > " " Then
' Name mvarSaveFile As mvarSaveFile & ".bak"
'End If
If Len(Dir$(mvarSaveFile)) > 0 Then
If MsgBox("目标文件以存在是否覆盖!", vbInformation + vbYesNo, "提示") = vbNo Then
Cancel
StartDownLoad = False
Exit Function
End If
End If
intfile = FreeFile()

Open mvarSaveFile For Binary Access Write As #intfile
Do
InternetReadFile hFile, sBuffer(1), 1024, Ret
DoEvents
If Ret = 1024 Then
If mvarConnect = False Then
StartDownLoad = False
GoTo Quit
End If

Put #1, , sBuffer
Else
For i = 1 To Ret
Put #1, , sBuffer(i)
DoEvents
Next i
End If
LBR = LBR + Ret
RaiseEvent GetData(LBR)
DoEvents
Loop Until Ret < 1024
RaiseEvent DownLoadOver
Quit:
Close #intfile
'if Dir$(mvarSaveFile & ".bak") > " " Then
' Kill mvarSaveFile
' Name mvarSaveFile & ".bak" As mvarSaveFile
'End If
Cancel

Exit Function

OutErr:
Err.Clear
Cancel
Close #intfile
RaiseEvent ErrMassage("文件" & mvarSaveFile & "正在使用,无法进行操作")
On Error GoTo 0

End Function

Public Sub Cancel()

mvarConnect = False
InternetCloseHandle hOpen
InternetCloseHandle hFile

End Sub

Public Property Let SaveFile(ByVal FileName As String)

mvarSaveFile = FileName

End Property

Public Property Let URL(ByVal URL As String)


mvarUrl = URL

End Property
Public Function GetHeader(Optional hdrName As String) As String

Dim tmp As Long
Dim tmp2 As String

If mvarConnect = False Then
GetHeader = "0"
Cancel
Exit Function
End If
If Buffer <> "" Then
Select Case UCase$(hdrName)
Case "CONTENT-LENGTH"
tmp = InStr(Buffer, "Content-Length")
tmp2 = Mid$(Buffer, tmp + 16, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "CONTENT-TYPE"
tmp = InStr(Buffer, "Content-Type")
tmp2 = Mid$(Buffer, tmp + 14, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "DATE"
tmp = InStr(Buffer, "Date")
tmp2 = Mid$(Buffer, tmp + 6, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "LAST-MODIFIED"
tmp = InStr(Buffer, "Last-Modified")
tmp2 = Mid$(Buffer, tmp + 15, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "SERVER"

上一个:Vb如何修改浏览器主页
下一个:VB中的Option Explicit语句有什么作用?

CopyRight © 2012 站长网 编程知识问答 www.zzzyk.com All Rights Reserved
部份技术文章来自网络,