----------------------------------------------------------
           黑客动画吧 http://www.hack58.com

           致力于中国最专业的黑客安全站点

           黑客动画吧，有你更精彩
-----------------------------------------------------------

大家好,我是傻小子 ^_^ 

VB打造自己的下载工具

Form1中的代码:

Private Sub Command1_Click()
    'do a single file download with form waiting for response from function
    Dim FileList As String
    FileList = Text1.Text & "," & Text2.Text & "," & "1"
    Call frmDnLoad.ShowDownLoad(FileList, Me)
   
End Sub

Private Sub Command2_Click()
    'do mutliple file downloads
    '--> I'm putting stuff here... but don't jazz their servers too much!
    '--> BE NICE!!!!!!!!!!!!!
    Dim FileList As String
    FileList = "http://www.planet-source-code.com/" & "," & "c:/planet-source-code.html" & "," & "1" & ","
    FileList = FileList & "http://www.foxnews.com/" & "," & "c:/fox_news.html" & "," & "1" & ","
    FileList = FileList & "http://www.cnn.com/" & "," & "c:/cnn.html" & "," & "1" & ","
    FileList = FileList & "http://sportsillustrated.cnn.com/" & "," & "c:/SIllustrated.html" & "," & "1" & ","
    FileList = FileList & "http://www.weather.com/" & "," & "c:/weatherChannel.html" & "," & "1" '<<<<< NO TRAILING COMMA!!!!!
    Call frmDnLoad.ShowDownLoad(FileList)
End Sub

Private Sub Form_Load()
    'This is a pretty weird sample mp3!  I have no clue what it's supposed to represent!
    Text1.Text = "http://www.mndsoft.com/downfiles/MSDN_forVB.rar"
    Text2.Text = "c:/MSDN.RAR"
    Text3.Text = ""
End Sub

frmDnLoad窗体中的代码:

Option Explicit 'I STILL hate this... but I do it for you!
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ This code is placed on PSC for the 3 or 4 coders on PSC that actually read, try, and then                                                   ++
'++ leave CONSTRUCTIVE comments/suggestions (and even ocasionally vote!) for code on PSC.                                                       ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ As for the rest of you...                                                                                                                   ++
'++ As My EX-mother-in-law would say: "You wouldn't be happy if they hung you with a golden rope."                                              ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ I GOT ALOT OF HELP FROM:                                                                                                                    ++
'++ http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/ibindstatuscallback/ibindstatuscallback.asp ++
'++ AND OF COURSE, Edamo's OLE interfaces & functions v1.81, available freely at:                                                               ++
'++ http://www.mvps.org/emorcillo/download/vb6/tl_ole.zip                                                                                       ++
'++ He has simple re-use requirements... see them at:                                                                                           ++
'++ http://www.mvps.org/emorcillo/en/index.shtml                                                                                                ++
'++ He has some other great stuff at: http://www.mvps.org/emorcillo/en/index.shtml, sadly, they have given up on VB long ago.                   ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ To save the inevitible question... NO YOU DON'T HAVE TO DISTRIBUTE THE TYPE LIBRARY!                                                        ++
'++ When you compile your project, VB will take what it needs and compiles it in your *.exe.  You only need the TLB for compiling.              ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ SEE THE README.TXT FILE to set this up!  Otherwise, save your emails!                                                                       ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Implements olelib.IBindStatusCallback 'initialize the IBindStatusCallback interface... otherwise, you'll get no progress reports
Private Function StartTheStinkinDownLoad(ByVal File2DownLoad As String, ByVal File2Save As String) As Boolean
  Dim DownLoadResult As Long
    '--> Start the download...
    '--> You should note that URLDownloadToFile overwrites any existing file without notification!
    DownLoadResult = olelib.URLDownloadToFile(Nothing, File2DownLoad, File2Save, 0, Me)
    '--> Report the results of the download attempt
    StartTheStinkinDownLoad = (DownLoadResult = olelib.S_OK)
End Function
Private Sub IBindStatusCallback_OnProgress(ByVal ulProgress As Long, ByVal ulProgressMax As Long, ByVal ulStatusCode As olelib.BINDSTATUS, ByVal szStatusText As Long)
    On Error GoTo BadDeal
    '--> un-remark the debug.prints if you want to see the interaction that's happening!
    'the OnProgress event is what keeps your ap from freezing during download ala URLDownloadToFile
    '--> just an fyi... IBindStatusCallback_OnProgress returns results in terms of bytes...
    '--> ulProgressMax = the total # bytes to download
    '--> ulProgress = the # of bytes downloaded thus far
    '--> ...you need to base your calculations in those terms
    If ulProgressMax <= 0 Then Exit Sub
    '^-this rascal screwed me around for well over an hour before I solved it!
    '... the initial call returns a zero for ulProgressMax and ulProgress... duh!
    '... if you use that zero for progressbar1.max you'll get an error.
    '... BTW I don't like the VB progress bar either... just put it here for convienience...
    '... so adapt the code below as needed for your progress bar.
    ProgressBar1.Max = CSng(ulProgressMax) ' set the progress bar's max value after it is known for sure
    'Be sure to set the max value before assigning the bar value!
    ProgressBar1.value = CSng(ulProgress) ' set the current level of progress
    DoEvents 'force a refresh... even though this slows things down
    'Debug.Print "ulProgress: " & ulProgress & " - ulProgressMax: " & ulProgressMax & " - Progbar max: " & ProgressBar1.Max
   
Exit Sub
BadDeal:
    'MsgBox "Progress: " & ulProgress & vbCrLf & "ulProgressMax: " & ulProgressMax
    'sometimes you'll get a wacky value for ulProgress (larger than ulProgressMax)
    'better to just let things slide till I can figure out why this normally works...
    'but then sometimes freaks out.
    Form1.Text3.Text = Form1.Text3.Text & "下载出错: " & ulProgress & "/" & ProgressBar1.value & "/" & ulProgressMax & "/" & ProgressBar1.Max & vbCrLf
    Resume Next
End Sub
Private Sub IBindStatusCallback_OnStartBinding(ByVal dwReserved As Long, ByVal pib As olelib.IBinding)
    'leave this sub here even if you don't utilize it!
    'all events need to be exposed... and so on for all IBind subs below
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_OnStartBinding"
End Sub
Private Sub IBindStatusCallback_OnStopBinding(ByVal hresult As Long, ByVal szError As Long)
    'leave this sub here even if you don't utilize it!
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_OnStopBinding"
End Sub
Private Sub IBindStatusCallback_GetBindInfo(grfBINDF As olelib.BINDF, pbindinfo As olelib.BINDINFO)
    'leave this sub here even if you don't utilize it!
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_GetBindInfo"
End Sub
Private Function IBindStatusCallback_GetPriority() As Long
    'leave this sub here even if you don't utilize it!
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_GetPriority"
End Function
Private Sub IBindStatusCallback_OnDataAvailable(ByVal grfBSCF As olelib.BSCF, ByVal dwSize As Long, pformatetc As olelib.FORMATETC, pStgmed As olelib.STGMEDIUM)
    'leave this sub here even if you don't utilize it!
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_OnDataAvailable"
End Sub
Private Sub IBindStatusCallback_OnLowResource(ByVal reserved As Long)
    'leave this sub here even if you don't utilize it!
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_OnLowResource"
End Sub
Private Sub IBindStatusCallback_OnObjectAvailable(riid As olelib.UUID, ByVal pUnk As stdole.IUnknown)
    'leave this sub here even if you don't utilize it!
    'see: http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/ifaces/urlmon_ref_ifaces_entry.asp
'Debug.Print "IBindStatusCallback_OnObjectAvailable"
End Sub
Public Function ShowDownLoad(FileList As String, Optional Owner As Object)
    '--> un-remark the debug.prints if you want to see the interaction that's happening!
    '--> it's fairly interesting... if you're into that sort of thing
    'split files to download from FileList
    Dim i, X As Integer
    i = Split(FileList, ",")
    'Draw a black box around the virtual title bar
    Me.Line (0, 0)-(Me.ScaleWidth - 1, 32), &H0&, B
    'draw the title gradient
    DrawGradient Me, 175, 177, 166, False, 0, 0, Me.ScaleWidth - 1, 16
    DrawGradient Me, 175, 177, 166, True, 0, 17, Me.ScaleWidth - 1, 31
    DrawGradient Me, 175, 177, 166, True, 1, 34, Me.ScaleWidth - 1, Me.ScaleHeight - 1
    'Draw the form border according to the colorscheme
    Me.ForeColor = &H0
    RoundRect Me.hdc, 0, 0, (Me.Width / Screen.TwipsPerPixelX) - 1, (Me.Height / Screen.TwipsPerPixelY) - 1, CLng(25), CLng(25)
    Me.ForeColor = &HA7A7A7
    RoundRect Me.hdc, 1, 1, (Me.Width / Screen.TwipsPerPixelX) - 2, (Me.Height / Screen.TwipsPerPixelY) - 2, CLng(25), CLng(25)
    '-->clip rounded corners transparent
    SetWindowRgn Me.hwnd, CreateRoundRectRgn(0, 0, (Me.Width / Screen.TwipsPerPixelX), (Me.Height / Screen.TwipsPerPixelY), 25, 25), True
    'get usable screen dimensions
    GetScreenInfo
    With Me
        .ForeColor = &H0
        .FontBold = True
        'I'll put the form on bottom right corner of screen... above toolbar if there
        'You can put it anywhere you like
        .Left = (ScreenDimensions.Right - Me.ScaleWidth) * Screen.TwipsPerPixelX
        .Top = (ScreenDimensions.Bottom - Me.ScaleHeight) * Screen.TwipsPerPixelY
        .CurrentX = 10
        .CurrentY = 10
    End With
    Me.Print "正在下载... 请稍候..." 'print caption here
    Label1.Caption = "检查复制缓存..."
    If IsMissing(Owner) = False Then
        Me.Show 'You're better off to show without owner form... otherwise the function will wait till you close the form before it does anything... :(
    Else
        Me.Show vbModeless, Owner 'I leave this incase you want response.
    End If
    Me.Refresh 'force form to be displayed 1st before processing the following code
    Dim File2DownLoad As String, File2Save As String, DeleteCache As Boolean, TopLimit As Integer, TempDelete As String, OffSet As Integer
    TopLimit = (UBound(i) - 2) / 3 'filelist comes in as:File2DownLoad,File2Save,DeleteCache
    OffSet = 0
    For X = 0 To TopLimit
        File2DownLoad = i(OffSet)
        File2Save = i(OffSet + 1)
        TempDelete = i(OffSet + 2)
        If TempDelete = "1" Then
            DeleteCache = True
        Else
            DeleteCache = False
        End If
        OffSet = OffSet + 3 'increment the offset for next file
        ProgressBar1.value = 0 'initialize the progress bar
        Form1.Text3.Text = Form1.Text3.Text & "开始下载文件..." & vbCrLf
        Form1.Text3.Text = Form1.Text3.Text & File2DownLoad & vbCrLf
        'You may want to download the file from IE's cache... if so... set DeleteCache = False
        'This could be called as: DeleteUrlCacheEntry File2DownLoad if you don't need result
        'Note that the remote URL is passed since this is the name that the cached file is known by.
        'This does NOT delete the file from the remote server... ONLY the local machine copy
        'Deleting the cached copy (if it exists) forces a new copy to be downloaded from internet
        If DeleteCache Then
            If DeleteUrlCacheEntry(File2DownLoad) = 1 Then 'found and deleted
                Form1.Text3.Text = Form1.Text3.Text & "找到上次下载缓存文件删除..." & vbCrLf
            Else
                Form1.Text3.Text = Form1.Text3.Text & "没有缓存文件存在" & vbCrLf 'no local copy existed
            End If
        End If
        Label1.Caption = File2DownLoad
        'Debug.Print File2DownLoad
        If StartTheStinkinDownLoad(File2DownLoad, File2Save) Then
            Form1.Text3.Text = Form1.Text3.Text & File2DownLoad & " 文件下载完毕!" & vbCrLf
            ShowDownLoad = True
        Else
            Form1.Text3.Text = Form1.Text3.Text & "文件下载失败!" & vbCrLf
            ShowDownLoad = False
            '-->you may want some other notification back to calling form here
        End If
    Next
    Form1.Text3.Text = Form1.Text3.Text & "开始下载文件..." & vbCrLf 'report leaving for the heck of it
    Unload Me 'report the last ShowDownLoad state to owner if any
End Function
Private Sub Form_DblClick()
    Unload Me
End Sub

模块中的代码:

Option Explicit

'--> declare api for downloading file
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

'--> declare api for deleting an existing file from IE's cache
Public Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
'--> needed constants
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000

'--> declare the api to draw the form border
Public Declare Function RoundRect Lib "gdi32" (ByVal hdc As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long, ByVal EllipseWidth As Long, ByVal EllipseHeight As Long) As Long

'--> declare api to round the form and clip for transparency
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Public Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal RectX1 As Long, ByVal RectY1 As Long, ByVal RectX2 As Long, ByVal RectY2 As Long, ByVal EllipseWidth As Long, ByVal EllipseHeight As Long) As Long

'--> declare api for draging the form around (mousedown anywhere on form ... except controls)
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'declare the SystemParametersInfo api
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_GETWORKAREA = 48 'Desktop Area with task bar consideration.
'Type structure to hold results of query
Public Type User_Vis_Screen_Rect
    Left As Long
    Top As Long
    Right As Long   'Width = Right - Left
    Bottom As Long  'Height = Bottom - Top
End Type
'assign the type
Public ScreenDimensions As User_Vis_Screen_Rect 'used to keep the actual screen size results (in pixels)
Public GetScreenData As Long ' API call requires a long number
Public StoreDimensions As User_Vis_Screen_Rect  'A good place to store results for later work

Public Sub DrawGradient(Thing As Object, R As Integer, G As Integer, B As Integer, Top2Bot As Boolean, X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer)
    'this sub draws the gradient on the 'download' form
    'it is modified from my msgbox replacement submission
    Dim RedStrt, GrnStrt, BluStrt, Red, Grn, Blu, UseRed, UseGreen, UseBlue, Trips, Dist, Y
   
    If Top2Bot Then
        RedStrt = 255: GrnStrt = 255: BluStrt = 255
        Red = R: Grn = G: Blu = B
    Else
        'swap values
        RedStrt = R: GrnStrt = G: BluStrt = B
        Red = 255: Grn = 255: Blu = 255
    End If
    Trips = Y2 - Y1
    If Trips < 1 Then Exit Sub 'prevent error... skip the gradient
    Dist = (Y2 - Y1) / 255
    For Y = 0 To Trips
        UseRed = (RedStrt / 255) * (255 - (Y / Dist)) + (Red / 255) * (Y / Dist)
        UseGreen = (GrnStrt / 255) * (255 - (Y / Dist)) + (Grn / 255) * (Y / Dist)
        UseBlue = (BluStrt / 255) * (255 - (Y / Dist)) + (Blu / 255) * (Y / Dist)
        Thing.Line (X1, Y1 + Y)-(X2, Y1 + Y), RGB(UseRed, UseGreen, UseBlue)
    Next
End Sub
Public Sub GetScreenInfo()
    'this sub gets the useable screen info for locating the download form
    'Call the SystemParametersInfo API
    GetScreenData = SystemParametersInfo(SPI_GETWORKAREA, vbNull, StoreDimensions, 0)
    'store results
    If GetScreenData Then
        'the API call was successful... returns dimensions in pixel terms
        ScreenDimensions.Left = StoreDimensions.Left
        ScreenDimensions.Right = StoreDimensions.Right
        ScreenDimensions.Top = StoreDimensions.Top
        ScreenDimensions.Bottom = StoreDimensions.Bottom
        'note: on my 800x600 monitor w/ single height taskbar at bottom...
        'ScreenDimensions.Left = 0
        'ScreenDimensions.Right = 800
        'ScreenDimensions.Top = 0
        'ScreenDimensions.Bottom = 572
        'therefore:
        'Total Available Width = ScreenDimensions.Right - ScreenDimensions.Left
        'Total Available Height = ScreenDimensions.Bottom - ScreenDimensions.Top
    Else
        'API call failed
        'try less sophisticated way
        ScreenDimensions.Left = 0
        ScreenDimensions.Right = Int(Screen.Width / Screen.TwipsPerPixelX) 'total screen width in pixels
        ScreenDimensions.Top = 0
        ScreenDimensions.Bottom = Int(Screen.Height / Screen.TwipsPerPixelY)
    End If
End Sub

我是黑吧傻小子  大家88888