dlmain.ctl

HTTP文件下载控件源代码 提供了使用HTTP下载文件时的控制方法及处理方法

VERSION 5.00
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
Begin VB.UserControl DownLoad 
   CanGetFocus     =   0   'False
   ClientHeight    =   480
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   480
   InvisibleAtRuntime=   -1  'True
   MaskColor       =   &H000000FF&
   MaskPicture     =   "DLMain.ctx":0000
   Picture         =   "DLMain.ctx":0844
   PropertyPages   =   "DLMain.ctx":1086
   ScaleHeight     =   480
   ScaleWidth      =   480
   ToolboxBitmap   =   "DLMain.ctx":10A8
   Begin InetCtlsObjects.Inet I1 
      Left            =   600
      Top             =   480
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
   End
End
Attribute VB_Name = "DownLoad"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Private Declare Function InternetGetConnectedState Lib "wininet" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean

Dim a_Resume As Boolean
Dim c_Cancel As Boolean
Dim c_Pause As Boolean
Dim m_URL As String
Dim m_FileSize As Long
Dim m_CHUNK As Long
Dim m_FileExists As Boolean
Dim m_Percent As Long
Dim m_Status As String
Dim m_BYTES As Long
Dim m_SaveLocation As String
Dim m_KeepType As Boolean
Dim m_OnlineCheck As Boolean
Dim m_PromptOverwrite As Boolean
Dim m_Connected As Boolean
Dim m_Resume As Boolean
Dim m_ROLLBACK As Long
Dim m_InDL As Boolean
Dim m_UserName As String
Dim m_Password As String
Dim t_OldTime As Single
Dim t_Time As Single
Dim r_RateTransfer As Single

Const INTERNET_CONNECTION_MODEM = 1
Const INTERNET_CONNECTION_LAN = 2
Const INTERNET_CONNECTION_PROXY = 4

Const d_URL = "http://members.tripod.com/darkmsoft/index.html"
Const d_CHUNK = 1024
Const d_SaveLocation = "C:\File1.tmp"
Const d_KeepType = False
Const d_OnlineCheck = False
Const d_PromptOverwrite = False
Const d_ROLLBACK = 5120

'error codes
'1 Unknown error
'2 File doesn't exist
'3 Server timed out
'4 canceled
'5 No Connection To Internet
'401 Unauthorized Access
'403 Access Denied

Event DLComplete()
Event DLError(lpErrorDescription As String)
Event DLECode(lErrorCode As Long)
Event RecievedBytes(lnumBYTES As Long)
Event Percent(lPercent As Long)
Event StatusChange(lpStatus As String)
Event Rate(lpRate As String)
Event TimeLeft(lpTime As String)
Event ConnectionState(strState As String)

Public Property Get InDL() As Boolean
InDL = m_InDL
End Property

Public Property Get AResume() As Boolean
AResume = a_Resume
End Property

Public Property Get CPause() As Boolean
CPause = c_Pause
End Property

Public Property Get CCancel() As Boolean
CCancel = c_Cancel
End Property

Public Property Get ROLLBACK() As Long
ROLLBACK = m_ROLLBACK
End Property

Public Property Let ROLLBACK(ByVal lnumBYTES As Long)
m_ROLLBACK = ROLLBACK
PropertyChanged "ROLLBACK"
End Property

Public Property Get ResumeSupported() As Boolean
ResumeSupported = a_Resume
End Property

Public Property Get Connected() As Boolean
Connected = m_Connected
End Property

Public Property Get PromptOverwrite() As Boolean
Attribute PromptOverwrite.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
PromptOverwrite = m_PromptOverwrite
End Property

Public Property Let PromptOverwrite(ByVal DoPrompt As Boolean)
m_PromptOverwrite = DoPrompt
PropertyChanged "PromptOverwrite"
End Property

Public Property Get OnlineCheck() As Boolean
OnlineCheck = m_OnlineCheck
End Property

Public Property Let OnlineCheck(ByVal DoCheck As Boolean)
m_OnlineCheck = DoCheck
PropertyChanged "OnlineCheck"
End Property

Public Property Get KeepType() As Boolean
KeepType = m_KeepType
End Property

Public Property Let KeepType(ByVal IsKeep As Boolean)
m_KeepType = IsKeep
PropertyChanged "KeepType"
End Property

Public Property Get FileExists() As Boolean
  FileExists = m_FileExists
End Property

Public Property Get FileSize() As Long
  FileSize = m_FileSize
End Property

Public Property Get Url() As String
Attribute Url.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
  Url = m_URL
End Property

Public Property Get CHUNK() As Long
Attribute CHUNK.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
CHUNK = m_CHUNK
End Property

Public Property Get SaveLocation() As String
Attribute SaveLocation.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
SaveLocation = m_SaveLocation
End Property

Public Property Let SaveLocation(ByVal New_Location As String)
m_SaveLocation = New_Location
PropertyChanged "SaveLocation"
End Property

Public Property Let CHUNK(ByVal New_CHUNK As Long)
m_CHUNK = New_CHUNK
PropertyChanged "CHUNK"
End Property

Public Property Let Url(ByVal New_Url As String)
m_URL = New_Url
PropertyChanged "Url"
End Property

Private Sub UserControl_InitProperties()
m_URL = d_URL
m_CHUNK = d_CHUNK
m_SaveLocation = d_SaveLocation
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_URL = PropBag.ReadProperty("URL", d_URL)
m_CHUNK = PropBag.ReadProperty("CHUNK", d_CHUNK)
m_SaveLocation = PropBag.ReadProperty("SaveLocation", d_SaveLocation)
m_KeepType = PropBag.ReadProperty("KeepType", d_KeepType)
m_OnlineCheck = PropBag.ReadProperty("OnlineCheck", d_OnlineCheck)
m_PromptOverwrite = PropBag.ReadProperty("PromptOverwrite", d_PromptOverwrite)
End Sub

Private Sub UserControl_Resize()
UserControl.Height = 480
UserControl.Width = 480
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("URL", m_URL, d_URL)
Call PropBag.WriteProperty("CHUNK", m_CHUNK, d_CHUNK)
Call PropBag.WriteProperty("SaveLocation", m_SaveLocation, d_SaveLocation)
Call PropBag.WriteProperty("KeepType", m_KeepType, d_KeepType)
Call PropBag.WriteProperty("OnlineCheck", m_OnlineCheck, d_OnlineCheck)
Call PropBag.WriteProperty("PromptOverwrite", m_PromptOverwrite, d_PromptOverwrite)
End Sub

Sub DownLoad()
On Error GoTo DLE
Dim lpHeader As String
Dim lpdestination As String
Dim lpdestination2 As String
Dim strreturn As String
Dim CHUNK As Long
Dim bData() As Byte
Dim intfile As Integer
Dim lBR As Long

If c_Cancel = True Then
Exit Sub
End If

If m_OnlineCheck = True Then
    If m_Connected = False Then
        RaiseEvent DLECode(5)
        RaiseEvent DLError("No Connection Found!")
        RaiseEvent StatusChange("Download aborted, no connection present!")
        I1.Cancel
        Exit Sub
    End If
End If

I1.Url = m_URL
CHUNK = m_CHUNK
lpdestination = m_SaveLocation
intfile = FreeFile()

If m_KeepType = True Then
lpdestination = KeepSave(m_URL, m_SaveLocation)
End If

If m_PromptOverwrite = True Then
    If Dir$(lpdestination) > " " Then
        strreturn = MsgBox("Would you like to overwrite the file at: " & lpdestination & " ?", vbInformation + vbYesNo, "Overwrite?")
            If strreturn = vbYes Then
                Kill lpdestination
            Else
404:            lpdestination2 = InputBox("Please type in a new file path and name." & vbCrLf & "Example: C:\File2.txt", "New File...", lpdestination)
                    If lpdestination2 <= " " Then
                        MsgBox "You didn't specify a file!", vbExclamation + vbOKOnly, "Error!"
                        GoTo 404
                    End If
                    If lpdestination = lpdestination2 Then
                        strreturn = MsgBox("You typed in the same file! Would you like type in a different file?", vbCritical + vbYesNo, "Try Again?")
                            If strreturn = vbYes Then
                                GoTo 404
                            End If
                    End If
            End If
    End If
Else
    If Dir$(lpdestination) > " " Then
        Kill lpdestination
    End If
End If

Open lpdestination For Binary Access Write As #intfile
RaiseEvent StatusChange("Opening " & lpdestination & " For DATA Input.")
m_InDL = True
Do
    If c_Cancel = True Then
    c_Cancel = False
    Close #intfile
    RaiseEvent DLECode(4)
    RaiseEvent StatusChange("Cancelled.")
    Exit Sub
    End If
    bData = I1.GetChunk(CHUNK, icByteArray)
    Put #intfile, , bData