frmmain.frm

URLDownload 带下载进度<-- 描述就那么多。。。

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmMain 
   Caption         =   "URLDownload"
   ClientHeight    =   4185
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   6030
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   4185
   ScaleWidth      =   6030
   StartUpPosition =   2  '屏幕中心
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   4920
      Top             =   1560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command4 
      Caption         =   "浏 览"
      Height          =   375
      Left            =   4920
      TabIndex        =   7
      Top             =   960
      Width           =   855
   End
   Begin VB.TextBox Text2 
      Height          =   270
      Left            =   240
      TabIndex        =   6
      Text            =   "D:\Documents and Settings\陈乐\桌面\采办及合同管理数据库-2.0_be.mdb"
      Top             =   1080
      Width           =   4575
   End
   Begin VB.TextBox Text1 
      Height          =   270
      Left            =   240
      TabIndex        =   5
      Text            =   "\\李斐\shjflFHKLAEEsahfjlasfLFHJALhuwoqeyruowq$\采办及合同管理数据库-2.0_be.mdb"
      Top             =   480
      Width           =   5535
   End
   Begin VB.CommandButton Command3 
      Caption         =   "退  出"
      Height          =   495
      Left            =   3720
      TabIndex        =   4
      Top             =   2760
      Width           =   1335
   End
   Begin VB.CommandButton Command2 
      Caption         =   "终  止"
      Height          =   495
      Left            =   2160
      TabIndex        =   3
      Top             =   2760
      Width           =   1335
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   255
      Left            =   1080
      TabIndex        =   1
      Top             =   2280
      Width           =   3495
      _ExtentX        =   6165
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开始下载"
      Height          =   495
      Left            =   600
      TabIndex        =   0
      Top             =   2760
      Width           =   1335
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      Height          =   255
      Left            =   600
      TabIndex        =   2
      Top             =   1800
      Width           =   4215
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Implements IBindStatusCallback
'控制下载的接口
Private m_oBind As IBinding
'是否在下载
Private m_fDownloading As Boolean
'对于下载控制接口的引用数
Private m_lRefCount As Long


Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
        (ByVal pCaller As IUnknown, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As IBindStatusCallback) As Long

Private Sub Command1_Click()
Dim r
DoEvents
If m_fDownloading Then Exit Sub

Dim oBindCallback As IBindStatusCallback

'获得IBindStatusCallback接口对象
Set oBindCallback = Me

ProgressBar1.Value = 0
Label1.Caption = ""
If Text1.Text = "" Or Text2.Text = "" Then
 MsgBox "请设置正确的下载和保存路径", vbOKOnly, "提示"
Else
     Command1.Enabled = False
     r = URLDownloadToFile(Me, Text1.Text, Text2.Text, 0, Me)
     If r = 0 Then
      Command1.Enabled = True
      DeleteUrlCacheEntry Text1.Text
      Else
       MsgBox "下载失败", vbOKOnly, "提示"
       Command1.Enabled = True
     End If

End If
End Sub


Private Sub Command2_Click()
On Error Resume Next
If m_lRefCount = 1 Then
If Not m_oBind Is Nothing Then m_oBind.Abort
End If
m_fDownloading = False
End Sub

Private Sub Command3_Click()
End
End Sub

Private Sub Command4_Click()
On Error Resume Next
Dim aa As String
Dim n As Integer
aa = Text1.Text
n = InStr(aa, "/")
If n = 0 Then
aa = Right(aa, InStr(StrReverse(aa), "\") - 1)
ElseIf n <> 0 And n > 0 Then
aa = Right(aa, InStr(StrReverse(aa), "/") - 1)
End If
  With CommonDialog1
   .DialogTitle = "保存文件"
   .FileName = aa
   .Filter = "All files|*.*"
   .ShowSave
  End With
Text2.Text = CommonDialog1.FileName
End Sub

 'IBindStatusCallback

Private Sub IBindStatusCallback_GetBindInfo(grfBINDF As olelib.BINDF, pbindinfo As olelib.BINDINFO)

End Sub


Private Function IBindStatusCallback_GetPriority() As Long

End Function

Private Sub IBindStatusCallback_OnDataAvailable(ByVal grfBSCF As olelib.BSCF, ByVal dwSize As Long, pformatetc As olelib.FORMATETC, pStgmed As olelib.STGMEDIUM)

End Sub

Private Sub IBindStatusCallback_OnLowResource(ByVal reserved As Long)

End Sub

Private Sub IBindStatusCallback_OnObjectAvailable(riid As olelib.UUID, ByVal pUnk As stdole.IUnknown)

End Sub

Private Sub IBindStatusCallback_OnProgress(ByVal ulProgress As Long, ByVal ulProgressMax As Long, ByVal ulStatusCode As olelib.BINDSTATUS, ByVal szStatusText As Long)
    Dim i As Long
    Dim aa
    Dim bb
    DoEvents
    ProgressBar1.Max = ulProgressMax
    ProgressBar1.Value = ulProgress
    ProgressBar1.Refresh
    'Me.Caption = ulProgress & "/" & ulProgressMax
    If ulProgress < 1000 Then
       aa = ulProgress & "Byte"
    ElseIf ulProgress >= 1000 And ulProgress < 1000000 Then
       aa = ((ulProgress / 1000) & "K")
    ElseIf ulProgress >= 1000000 Then
       aa = (((ulProgress \ 1000) / 1000) & "M")
    End If
    If ulProgressMax < 1000 Then
       bb = ulProgressMax & "Byte"
    ElseIf ulProgressMax >= 1000 And ulProgress < 1000000 Then
       bb = ((ulProgressMax / 1000) & "K")
    ElseIf ulProgressMax >= 1000000 Then
       bb = (((ulProgressMax \ 1000) / 1000) & "M")
    End If
    Label1.Caption = aa & "/" & bb
    
End Sub

Private Sub IBindStatusCallback_OnStartBinding(ByVal dwReserved As Long, ByVal pib As olelib.IBinding)
m_fDownloading = True
Set m_oBind = pib
m_oBind.Abort
m_lRefCount = 1
End Sub

Private Sub IBindStatusCallback_OnStopBinding(ByVal hresult As Long, ByVal szError As Long)
m_fDownloading = False
If m_lRefCount = 1 Then
Set m_oBind = Nothing
m_lRefCount = 0
End If
End Sub