vbAccelerator - Contents of code file: FontComboVB_FontComboBox.vb

Namespace FontCombo

    '' <summary>
    '' Summary description for FontCombo.
    '' </summary>
    Public Class FontComboBox
        Inherits vbAccelerator.Components.Controls.IconComboBox

        ''' <summary>
        ''' Collection of Most-Recently used fonts
        ''' </summary>
        Private m_mruFonts As MRUFonts
        ''' <summary>
        ''' Number of MRU fonts currently displayed
        ''' </summary>
        Private mruItemCount As Integer = 0
        ''' <summary>
        ''' Enable state before/whilst background thread loading in progress
        ''' </summary>
        Private origEnable As Boolean = True
        ''' <summary>
        ''' Whether the actual control's enable state can be modified
        ''' </summary>
        Private allowEnable As Boolean = False
        ''' <summary>
        ''' An interlock which prevents events from being raised when items
        ''' are being added or swapped Integero the MRU font list
        ''' </summary>
        Private interlock As Boolean = False

#Region " Events"
        ''' <summary>
        ''' Raised when the font combo box has been populated.  Fonts are
        ''' populated asynchronously on a background thread.
        ''' </summary>
        Public Event Populated(ByVal sender As Object, ByVal e As EventArgs)
#End Region

        ''' <summary>
        ''' Constructs a new instance of this class.
        ''' </summary>
        Public Sub New()
            MyBase.New()
            MyBase.MaxDropDownItems = 16
            MyBase.DropDownWidth = 300
            MyBase.AutoComplete = True
            m_mruFonts = New MRUFonts(Me)
        End Sub

        ''' <summary>
        ''' Gets/sets whether the control is enabled.  Whilst font loading
        ''' is occuring on a background thread, changes to this property
        ''' won't appear until loading has completed.
        ''' </summary>
        Public Shadows Property Enabled() As Boolean
            Get
                If Not (allowEnable) Then
                    Return origEnable
                Else
                    Return MyBase.Enabled
                End If
            End Get
            Set(ByVal Value As Boolean)
                If Not (allowEnable) Then
                    origEnable = Value
                Else
                    MyBase.Enabled = Value
                End If
            End Set
        End Property

        ''' <summary>
        ''' Raises the <see cref="HandleCreated"/> event and populates
        ''' the combo box with fonts.
        ''' </summary>
        ''' <param name="e">Not used</param>
        Protected Overrides Sub OnHandleCreated(ByVal e As EventArgs)

            MyBase.OnHandleCreated(e)

            LoadFonts()

        End Sub

        ''' <summary>
        ''' Raises the <see cref="SelectedIndexChanged"/> event,
        ''' also the MRU cache is correctly populated.
        ''' </summary>
        ''' <param name="e"></param>
        Protected Overrides Sub OnSelectedIndexChanged(ByVal e As EventArgs)
            If Not (interlock) Then
                MyBase.OnSelectedIndexChanged(e)

                If ((MyBase.SelectedIndex > -1) And Not (MyBase.DroppedDown))
                 Then
                    addMRUFont(MyBase.SelectedItem.ToString())
                End If
            End If
        End Sub

        ''' <summary>
        ''' Gets the collection of most-recently used fonts in the control.
        ''' </summary>
        Public ReadOnly Property MostRecentlyUsedFonts() As MRUFonts
            Get
                Return m_mruFonts
            End Get
        End Property

        ''' <summary>
        ''' Adds a font family to the Most-Recently Used
        ''' font cache.
        ''' </summary>
        ''' <param name="familyName">Font family name to add</param>
        Private Sub addMRUFont(ByVal familyName As String)

            interlock = True

            If (m_mruFonts.Size > 0) Then
                Dim presentIndex As Integer = -1
                Dim i As Integer
                For i = 0 To mruItemCount - 1
                    Dim ici As vbAccelerator.Components.Controls.IconComboItem
                     = MyBase.Items(i)
                    If (ici.Text.ToString().Equals(familyName)) Then
                        presentIndex = i
                        Exit For
                    End If
                Next i

                Dim oldMruItemCount As Integer = mruItemCount
                If (presentIndex > -1) Then
                    '' remove existing item:
                    MyBase.Items.RemoveAt(presentIndex)
                    mruItemCount -= 1
                ElseIf ((m_mruFonts.Size = mruItemCount)) Then
                    '' remove the last MRU font:
                    MyBase.Items.RemoveAt(mruItemCount - 1)
                    mruItemCount -= 1
                End If

                ' Find the item:
                Dim realItem As Integer = MyBase.FindStringExact(familyName)
                Dim realIconComboItem As
                 vbAccelerator.Components.Controls.IconComboItem =
                 MyBase.Items(realItem)

                ' insert the item:         
                Dim mruItem As vbAccelerator.Components.Controls.IconComboItem
                 = New vbAccelerator.Components.Controls.IconComboItem()
                mruItem.Text = realIconComboItem.Text
                mruItem.Font = realIconComboItem.Font
                mruItem.Tag = "MRU"
                MyBase.Items.Insert(0, mruItem)

                mruItemCount += 1

                If (oldMruItemCount > 0) Then
                    '' remove underscore:
                    Dim oldLastMruItem As
                     vbAccelerator.Components.Controls.IconComboItem =
                     MyBase.Items(oldMruItemCount - 1)
                    oldLastMruItem.LineBelow = False
                End If

                m_mruFonts.Add(familyName)

                MyBase.SelectedIndex = 0
            End If

            interlock = False
        End Sub

        ''' <summary>
        ''' Reparses the contents of the MRU Font object after it
        ''' has been updated by the user of the control.
        ''' </summary>
        Protected Overridable Sub OnMRUChanged()
            If Not (interlock) Then
                '' redraw the MRU Fonts based on the newly specified ones.
                interlock = True

                MyBase.BeginUpdate()
                Dim i As Integer
                For i = 0 To mruItemCount - 1
                    MyBase.Items.Remove(0)
                Next i
                mruItemCount = 0

                If (m_mruFonts.Size > 0) Then
                    For i = m_mruFonts.Size - 1 To 0 Step -1
                        Dim ici As
                         vbAccelerator.Components.Controls.IconComboItem = New
                         vbAccelerator.Components.Controls.IconComboItem()

                        Dim realItem As Integer =
                         MyBase.FindStringExact(m_mruFonts(i))
                        Dim realIconComboItem As
                         vbAccelerator.Components.Controls.IconComboItem =
                         MyBase.Items(realItem)

                        ' insert the item:         
                        Dim mruItem As
                         vbAccelerator.Components.Controls.IconComboItem = New
                         vbAccelerator.Components.Controls.IconComboItem()
                        mruItem.Text = realIconComboItem.Text
                        mruItem.Font = realIconComboItem.Font
                        mruItem.Tag = "MRU"
                        MyBase.Items.Insert(0, ici)
                    Next i
                    Dim newLastMRUItem As
                     vbAccelerator.Components.Controls.IconComboItem =
                     MyBase.Items(mruItemCount - 1)
                    newLastMRUItem.LineBelow = True
                End If

                MyBase.EndUpdate()

                interlock = False
            End If
        End Sub

        ''' <summary>
        ''' Initiates a load of all fonts asynchronously.  The
        ''' <see cref="Populated"/> event will be fired once
        ''' all fonts are available.  Called automatically
        ''' whenever the control is created.
        ''' </summary>
        Public Sub LoadFonts()

            If Not (Me.Site Is Nothing) Then
                If (Me.Site.DesignMode) Then
                    Return
                End If
            End If

            origEnable = MyBase.Enabled
            MyBase.Enabled = False
            allowEnable = False
            interlock = True

            MyBase.Items.Clear()

            '' run font population on a background thread
            Dim populator As PopulateFontComboHandler = New
             PopulateFontComboHandler(AddressOf PopulateFontCombo)
            populator.BeginInvoke(Nothing, Nothing)

        End Sub

#Region " Asynchronous Font Population"
        Private Delegate Sub PopulateFontComboHandler()

        Private Sub PopulateFontCombo()

            ' This graphics object is used for determining the Panose
            ' number of the font
            Dim gfx As Graphics = Graphics.FromHwnd(MyBase.Handle)

            ' Get the collection of installed fonts:
            Dim fonts As System.Drawing.Text.InstalledFontCollection = _
                New System.Drawing.Text.InstalledFontCollection()

            ' For each item:
            Dim family As FontFamily
            For Each family In fonts.Families
                ' Find which style can be rendered (if any!)
                Dim theFont As Font = Nothing
                If (family.IsStyleAvailable(FontStyle.Regular)) Then
                    theFont = New Font(family.Name, 12)
                ElseIf (family.IsStyleAvailable(FontStyle.Bold)) Then
                    theFont = New Font(family.Name, 12, FontStyle.Bold)
                ElseIf (family.IsStyleAvailable(FontStyle.Italic)) Then
                    theFont = New Font(family.Name, 12, FontStyle.Italic)
                End If

                ' Here you could still add the item even if there are no
                ' styles you can render it in (although that probably
                ' wouldn't be much use...)
                If Not (theFont Is Nothing) Then
                    ' Create a new item:
                    Dim ici As vbAccelerator.Components.Controls.IconComboItem
                     = New vbAccelerator.Components.Controls.IconComboItem()
                    ' Set the text:
                    ici.Text = family.Name

                    ' Set the font to display the item in.
                    ' Don't try and display fonts like Wingdings using 
                    ' the font itself:
                    If (FontUtility.PanoseFontFamilyType(gfx, theFont) <> _
                     FontUtility.PanoseFontFamilyTypes.PAN_FAMILY_PICTORIAL)
                      Then
                        ici.Font = theFont
                    End If
                    MyBase.Items.Add(ici)
                End If
            Next
            gfx.Dispose()

            Dim complete As PopulateFontComboCompleteHandler = New
             PopulateFontComboCompleteHandler(AddressOf
             PopulateFontComboComplete)
            complete.BeginInvoke(Nothing, Nothing)

        End Sub

        Private Delegate Sub PopulateFontComboCompleteHandler()

        Private Sub PopulateFontComboComplete()

            ' Shift the MRU fonts to the top of the list:
            Dim i As Integer
            For i = m_mruFonts.Count - 1 To 0 Step -1
                addMRUFont(m_mruFonts(i))
            Next i
            MyBase.Enabled = origEnable
            allowEnable = True
            interlock = False

            OnPopulateComplete(New EventArgs())

        End Sub
#End Region

        ''' <summary>
        ''' Raises the <see cref="Populated"/> event.
        ''' </summary>
        ''' <param name="e">Not used.</param>
        Protected Overridable Sub OnPopulateComplete(ByVal e As EventArgs)
            RaiseEvent Populated(Me, e)
        End Sub


        ''' <summary>
        ''' Most Recently Used fonts collection associated with 
        ''' a <see cref="FontComboBox"/> control.
        ''' </summary>
        <SerializableAttribute()> _
        Public Class MRUFonts
            Inherits MRUQueue

            ''' <summary>
            ''' The owning control for this collection
            ''' </summary>
            Private m_owner As FontComboBox = Nothing

            ''' <summary>
            ''' Constructs a new instance of this class, associating
            ''' it with the owning <see cref="FontComboBox"/>.  Used
            ''' Integerernally by the <see cref="FontComboBox"/> control.
            ''' </summary>
            ''' <param name="owner"></param>
            Public Sub New(ByVal owner As FontComboBox)
                MyBase.New()
                m_owner = owner
            End Sub

            ''' <summary>
            ''' Gets the font family at the specified index.
            ''' </summary>
            Default Public Shadows ReadOnly Property Item(ByVal index As
             Integer) As String
                Get
                    Return MyBase.innerList(index)
                End Get
            End Property

            ''' <summary>
            ''' Adds the specified font name to the MRU queue.  If the queue
            ''' already contains the specified item, it is shifted up
            ''' to the first position.  Otherwise, it is added at the
            ''' first position and any existing items are shuffled 
            ''' downwards.
            ''' </summary>
            ''' <param name="fontName">fontName to add</param>
            Public Shadows Sub Add(ByVal fontName As String)
                MyBase.Add(fontName)
                m_owner.OnMRUChanged()
            End Sub

            ''' <summary>
            ''' Clears the MRU collection and notifies the control
            ''' of the change.
            ''' </summary>
            Protected Overrides Sub OnClear()
                MyBase.OnClear()
                m_owner.OnMRUChanged()
            End Sub

            ''' <summary>
            ''' Changes the size of the MRU collection and notifies the
            ''' control of the change.
            ''' </summary>
            Protected Overrides Sub OnSizeChanged()
                MyBase.OnSizeChanged()
                m_owner.OnMRUChanged()
            End Sub

        End Class

    End Class

End Namespace