Class' ----------------------------------------------------------------- ------------- Option ExplicitImplements IbindStatusCallback
'Get string Function Private Declare Function Lstrlena lib "kernel32" (Byval LPSTRING As Long) As longprivate declare function lstrlenw lib "kernel32" (Byval LPSTRING AS long) As long
Private Declare Function lstrcpyA Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As LongPrivate Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long 'download function Private Declare Function URLDownloadToFile Lib " Urlmon "Alias" URLDOWNLOADTOFILEA "(Byval Szurl As String, Byval SzFileName As String, BYVAL DWRESERVED AS long, BYVAL LPFNCB AS Long) As long
'Control Download Interface Private M_Obind As Ibinding' Download PRIVATE M_FDOWNLOADING As Boolean '' for Download Control Interface PRIVATE M_LREFCOUNT AS Long
'Download Progress Events Public Event Onprogress (Byval Lmaxprogress As Long, Byval LstatusCode As stay)
'Initialization Private Sub Class_Initialize () m_fdownload = false m_lrefcount = 0nd Sub
'End Private Sub Class_Terminate () if M_LREFCOUNT = 1 Then if not m_obind is nothingim_obind.release end if m_fdownload = false
'Start Download Public Function StartDownloading (ByVal sSrc As String, ByVal sDest As String) As Boolean' If you have to exit If m_fDownloading download Then Exit Function Dim oBindCallback As IBindStatusCallback 'get IBindStatusCallback interface objects Set oBindCallback = Me' to start the download StartDownloading = ( URLDownloadTofile (Objptr (ME), SSRC, SDEST, 0, Objptr (ObindCallback) = 0) End Function
'Abort downloading Public Sub AbortDownloading () On Error Resume Next If m_lRefCount = 1 Then If Not m_oBind Is Nothing Then m_oBind.Abort End If m_fDownloading = FalseEnd Sub' string obtained Public Function StrFromPtr (ByVal lpString As Long from a character pointer, Optional fUnicode As Boolean = False) As String On Error Resume Next If fUnicode Then StrFromPtr = String (lstrlenW (lpString), Chr (0)) lstrcpyW StrPtr (StrFromPtr), ByVal lpString Else StrFromPtr = String (lstrlenA (lpString), Chr (0) ) LSTRCPYA BYVAL STRFROMPTR, BYVAL LPSTRING END IFEND FUNCTION
'********************************************************** *********************************************************** *********************************************************************************** *********************************************************** *********************************************************** ********************************************** Private subindstatuscallback_getbindInfo (Grfbindf As Long, PbindInfo As Long) 'End Sub
Private subindstatuscallback_getpriority (PNPRIORITY As Long) 'End Sub
Private sub ibindstatuscallback_ondataavailable (Byval Dwsize As Long, PFormatetc As Long, PSTGMED AS Long) End Sub
Private sub ibindstatuscallback_onlowresource (Byval Reserved As long) 'end sub
Private sub ibindstatuscallback_onobjectavailable (Byval Riid As Long, Byval Punk As Urlmonlib.iunknownvb) 'End Sub
'Download progress Private Sub IBindStatusCallback_OnProgress (ByVal ulProgress As Long, ByVal ulProgressMax As Long, ByVal ulStatusCode As Long, ByVal szStatusText As Long) RaiseEvent OnProgress (ulProgress, ulProgressMax, ulStatusCode, StrFromPtr (szStatusText, True)) DoEventsEnd Sub
'Start downloading bind Private Sub IBindStatusCallback_OnStartBinding (ByVal dwReserved As Long, ByVal pib As URLMonLib.IBinding) m_fDownloading = True Set m_oBind = pib m_oBind.AddRef m_lRefCount = 1End Sub' end Download bindings Private Sub IBindStatusCallback_OnStopBinding (ByVal hresult As Long, ByVal Szerror As Long) m_fdownload = false if m_lrefcount = 1 Then m_obind.release m_lrefcount = 0 End IFEND SUB
Private sub ibindstatuscallback_remotegetBindInfo (Grfbindf As Long, PSTGMED As Long "end sub
Private subindstatuscallback_remoteondataavailable (Byval DWSIZCF AS Long, Byval Dwsize As Long, PFormatetc As Long, PSTGMED AS Long) 'End Sub' ------------------------ ------------------------------------- End Class'Form1 '-------- -------------------------------------------------- --------- Option ExplicitPrivate WitHevents M_ofiledownload As cfiledownloadownload
Private Sub cmdStart_Click () pb.Value = 0 cmdStart.Enabled = False cmdStop.Enabled = True Me.Caption = "Downloading ......" If m_oFileDownload.StartDownloading (txtSrc.Text, txtDest.Text) Then MsgBox "download success!" Else msgbox "Download failed!" End if cmdstart.enabled = true cmdstop.enabled = false me.caption = "l闲" lblprogress.caption = "Download progress" End Sub
PRIVATE SUB CMDSTOP_CLICK () cmdstart.enabled = true cmdstop.enabled = false me.caption = "idle" lblprogress.caption = "Download progress" m_ofiledownload.AbortdownLoadInd Sub
Private Sub Form_Load () Set m_oFileDownload = New CFileDownload Me.Caption = "idle" lblProgress.Caption = "Download progress" cmdStart.Enabled = True cmdStop.Enabled = FalseEnd SubPrivate Sub Form_Unload (Cancel As Integer) Set m_oFileDownload = NothingEnd Sub
Private Sub m_oFileDownload_OnProgress (ByVal lProgress As Long, ByVal lMaxProgress As Long, ByVal lStatusCode As Long, ByVal sStatusText As String) Dim bPercent As Long If lMaxProgress = 0 Then bPercent = 0 Else bPercent = Int (lProgress / lMaxProgress * 100) End If pb .Value = bPercent lblProgress.Caption = "downloaded" & CStr (bPercent) & "%" txtStatusText.Text = txtStatusText.Text & sStatusText txtStatusText.Text = txtStatusText.Text & vbCrLf txtStatusText.SelStart = Len (txtStatusText.Text) End Sub
