如何用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语句有什么作用？
更多图片编程知识:
VB编程问题

关于VB的问题

VB怎么实现不断查询条件是否满足

求助，VB程序运行突然变慢

请大神帮忙，点击某个账号，显示该条记录的折线图，万分感谢

VB问题，求解答，在线等