bkdlcontrol.ctl

一个比较简单美观的魔域登陆器源码

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, x, Y)
End Sub

'More Run-time/Read-only
'Total size of file in bytes
Public Property Get FileSize()
Attribute FileSize.VB_MemberFlags = "400"
    FileSize = m_lFileSize
End Property

'The URL to be downloaded from
Public Property Get FileURL() As String
Attribute FileURL.VB_Description = "URL of file to be Downloaded"
Attribute FileURL.VB_ProcData.VB_Invoke_Property = ";Misc"
Attribute FileURL.VB_MemberFlags = "400"
    FileURL = m_sFileURL
End Property

Public Property Let FileURL(ByVal New_FileURL As String)
    m_sFileURL = New_FileURL
    'determine the full filename
    SetFileName
    PropertyChanged "FileURL"
End Property

'Full filename: read-only at runtime
'Made from the File specified at the end of FileURL and
'the SaveFilePath
Public Property Get SaveFileName() As String
Attribute SaveFileName.VB_ProcData.VB_Invoke_Property = ";Misc"
Attribute SaveFileName.VB_MemberFlags = "400"
    SaveFileName = m_sSaveFileName
End Property

'Folder location to send all downloaded files to
Public Property Get SaveFilePath() As String
Attribute SaveFilePath.VB_Description = "Path to Save downloaded file to"
Attribute SaveFilePath.VB_ProcData.VB_Invoke_Property = ";Misc"
    SaveFilePath = m_sSaveFilePath
End Property

Public Property Let SaveFilePath(ByVal New_SaveFilePath As String)
    m_sSaveFilePath = New_SaveFilePath
    'determine the full filename
    SetFileName
    PropertyChanged "SaveFilePath"
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    Set Font = Ambient.Font
    m_sFileURL = vbNullString
    m_sSaveFilePath = vbNullString
    'Defaults to FailOnRedirect=True on the assumtion
    'that it is most often a redirect to a 404error.html file!
    m_blnFailRedirect = True
    'If not fail, next best bet is to rename (i.e., save
    '"path\404error.html" rather than the intended filename)
    'Note that this will be shown as False in prop browser if
    'FailOnRedirect is still True!
    m_blnRenameRedirect = True
    'Use the control itself as a progress bar
    InitDL ' blank out the 'get property' fields
    m_blnShowProgress = True

End Sub

'Progress bar drawing here
'Here it gets done only when necessary (control visible on screen)
Private Sub UserControl_Paint()
    If m_blnShowProgress And sngPct > 0! Then
        UserControl.Line (0, 0)-(UserControl.Width * sngPct, UserControl.Height), UserControl.ForeColor, BF
    End If
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Set Font = PropBag.ReadProperty("Font", Ambient.Font)
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    m_sFileURL = PropBag.ReadProperty("FileURL", vbNullString)
    m_sSaveFilePath = PropBag.ReadProperty("SaveFilePath", vbNullString)
    m_blnFailRedirect = PropBag.ReadProperty("FailOnRedirect", True)
    m_blnRenameRedirect = PropBag.ReadProperty("RenameOnRedirect", True)
    m_blnShowProgress = PropBag.ReadProperty("ShowProgress", True)
End Sub

'cancel any ongoing downloads
Private Sub UserControl_Terminate()
    If blnDownloading Then
        On Error Resume Next 'Might throw error if just begun and
                                'first conn. has not yet occured
        UserControl.CancelAsyncRead m_sSaveFileName
    End If
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "BackColor", UserControl.BackColor, &H8000000F
    PropBag.WriteProperty "ForeColor", UserControl.ForeColor, &H80000012
    PropBag.WriteProperty "Enabled", UserControl.Enabled, True
    PropBag.WriteProperty "Font", Font, Ambient.Font
    PropBag.WriteProperty "BorderStyle", UserControl.BorderStyle, 1
    PropBag.WriteProperty "FileURL", m_sFileURL, vbNullString
    PropBag.WriteProperty "SaveFilePath", m_sSaveFilePath, vbNullString
    PropBag.WriteProperty "FailOnRedirect", m_blnFailRedirect, True
    PropBag.WriteProperty "RenameOnRedirect", m_blnRenameRedirect, True
    PropBag.WriteProperty "ShowProgress", m_blnShowProgress, True
End Sub

'Trigger the
Public Function BeginDownload(Optional Wait As Boolean = False) As Boolean
    If blnDownloading Then Exit Function
    'check that we have a "to" and "from"...
    If m_sFileURL = vbNullString Or m_sSaveFilePath = vbNullString Then Exit Function
    On Error GoTo BeginDownloadError
    'here's the heart of it:
    UserControl.AsyncRead m_sFileURL, vbAsyncTypeByteArray, m_sSaveFileName, vbAsyncReadForceUpdate
    blnDownloading = True 'Internal check
    'blank of the dl property gets
    InitDL
    If Wait Then
        'wait until the downlad is complete, then return success or failure
        'Disadvantage: main code can't Cancel the download with this option
        'because main code is suspended!
        DoWait
        BeginDownload = blnSuccess
    Else
        BeginDownload = True 'Signal successful start and return to main code
    End If
    Exit Function
BeginDownloadError:
    SendError bkDLEUnavailable, Err.Description
    MsgBox Err & "Error: " & vbCrLf & Err.Description, vbCritical, "bkDLControl Internal Error: " & CStr(Err.Number)
End Function

Private Sub InitDL()
    m_lFileSize = 0&
    m_lBytesRead = 0&
    m_sConn = vbNullString
    m_sCache = vbNullString
    m_sRedirect = vbNullString
    m_sMIMEType = vbNullString
    blnSuccess = False

End Sub

'Basic loop 'til control variable changes
'the Async download will continue to fire events during this loop
'At some point, the download will complete itself or fail, and
'blndownloading will be false and the loop will exit
Private Sub DoWait()
    Do
        DoEvents
    Loop Until Not blnDownloading
End Sub

Public Sub CancelDownload()
    If Not blnDownloading Then Exit Sub
    'Throws an error if DL really hasn't started yet (no progress)
    '(safe to ignore error)
    On Error Resume Next
    UserControl.CancelAsyncRead m_sSaveFileName
    On Error GoTo 0
    sngPct = 0!
    Refresh
    blnDownloading = False
    RaiseEvent DLCanceled
End Sub

'If download is re-directed we might not get the file
'we wanted.  Defaults to fail (DLError) if redirected
Public Property Get FailOnRedirect() As Boolean
    FailOnRedirect = m_blnFailRedirect
End Property

Public Property Let FailOnRedirect(NewFail As Boolean)
    m_blnFailRedirect = NewFail
    PropertyChanged "FailOnRedirect"
End Property

'If download is re-directed we might not get the file
'we wanted., but we can save whatever we do get under
'it's original name
Public Property Get RenameOnRedirect() As Boolean
Attribute RenameOnRedirect.VB_ProcData.VB_Invoke_Property = ";Behavior"
    RenameOnRedirect = m_blnRenameRedirect And Not m_blnFailRedirect
End Property

Public Property Let RenameOnRedirect(NewRename As Boolean)
    m_blnRenameRedirect = NewRename
    PropertyChanged "RenameOnRedirect"
End Property

'Use control as progress bar
'Control also still has .hWnd and .hDC, so you can
'draw your own if you don't like my primitive prog bar.
Public Property Get ShowProgress() As Boolean
Attribute ShowProgress.VB_ProcData.VB_Invoke_Property = ";Behavior"
    ShowProgress = m_blnShowProgress
End Property

Public Property Let ShowProgress(NewShowProgress As Boolean)
    m_blnShowProgress = NewShowProgress
    PropertyChanged "ShowProgress"
End Property

'This works but it is so ugly I took it out!
'Public Sub ChangeToolTip()
'Dim sName As String, iOpenParen As Integer, iCloseParen As Integer
'    sName = UserControl.Ambient.DisplayName
'    'Get reference to self and change own tooltip
'    'Would have sworn there was an easier way but can't find it.  Brain fart.
'    On Error GoTo InArray
'    UserControl.Parent.Controls.Item(sName).ToolTipText = Format(sngPct, "0%")
'    Exit Sub
'InArray:
'    If Err = 730 Then
'        iOpenParen = InStr(1, sName, "(")
'        iCloseParen = InStr(iOpenParen, sName, ")")
'        UserControl.Parent.Controls.Item(Left(sName, iOpenParen - 1), _
'            CInt(Mid(sName, iOpenParen + 1, iCloseParen - iOpenParen - 1))).ToolTipText = Format(sngPct, "0%")
'    End If
'End Sub

'Little function to combine path & filename
Private Function getFullPath(strPath As String, strFile As String, Optional strDelim As String = "\") As String
    If Right$(strPath, 1) = strDelim Then
        getFullPath = strPath & strFile
    Else
        getFullPath = strPath & strDelim & strFile
    End If
End Function

'little function to retrieve filename (text after last "\" in path)
Private Function getFileFromPath(strPath As String, Optional strDelim As String = "\") As String
Dim iPos As Integer
    iPos = InStrRev(strPath, strDelim)
    If iPos = 0 Then
        getFileFromPath = strPath
    Else
        getFileFromPath = Mid$(strPath, iPos + 1)
    End If
End Function

'The filename is made of the path + the file name from the URL
'i.e., if path is "C:\Downloads" and url is '
'"http://www.blueknot.com/Downloads/ProjecTile.zip"
'the SaveFileName will be "C:\Downloads\ProjecTile.zip"
Private Sub SetFileName()
    If m_sFileURL = vbNullString Or m_sSaveFilePath = vbNullString Then
        m_sSaveFileName = vbNullString
    Else
        m_sSaveFileName = getFullPath(m_sSaveFilePath, getFileFromPath(Replace$(m_sFileURL, "/", "\")))
    End If
End Sub

'Like above, but use the redirect path to get the 'new' file name
Private Sub SetRedirectName()
    m_sSaveFileName = getFullPath(m_sSaveFilePath, getFileFromPath(Replace$(m_sRedirect, "/", "\")))
End Sub

'When stopping on an error, a message is sent to the DLError event,
'Plus the DLComplete event fires w/ 0& bytes downloaded
Private Sub SendError(E As bkDLError, strMessage As String)
    sngPct = 0!
    Refresh
    blnDownloading = False
    RaiseEvent DLError(E, strMessage)
    RaiseEvent DLComplete(0&)
End Sub