Tipp-Upload: VB.NET 0030: update zu 0015 - FontListBox

Über den Tipp  

Dieser Vorschlag soll VB.NET Tipp 0015 ersetzen.

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Grafik
• Listensteuerelemente

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
ownerdrawing, font, thread

Der Vorschlag wurde erstellt am: 03.09.2007 02:50.
Die letzte Aktualisierung erfolgte am 08.04.2008 13:56.

Zurück zur Übersicht

Beschreibung  

Umbau von .Net-Tipp0015. Dieser funktionierte nur unter VB7, da VB8 threadübergreifende Aufrufe streng überwacht. Inzwischen hat sich herausgestellt, daß die schlechte Performance nicht vom Laden der Fonts herrührte, sondern vom Laden der Fehlerbehandlungsbibliothek. Das Vermeiden des Fehlers erübrigt nun auch das Threading.
Konzeptionell ist umgestellt von "Listbox beerben" auf "Listbox kapseln" (im UserControl), da ein Listbox-Erbe viele Listbox-Properties offenlegt, die bei ungünstiger Einstellung die Funktion verhindern würden.
Der Code läuft unter VB7 **und** VB8.
ursprünglicher Tipp-Author ist Herfried K. Wagner.

Zusätzlicher Hinweis: In vielen Fällen kann man einfacher den System.Windows.Forms.FontDialog verwenden.

Anregungen zum Vorschlag bitte unter:
http://foren.activevb.de/cgi-bin/foren/view.pl?forum=13&msg=1387&root=1387&page=1

Schwierigkeitsgrad

Verwendete API-Aufrufe:

Download: Download des Beispielprojektes [9,39 KB]

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!
'
' Beachten Sie, das vom Designer generierter Code hier ausgeblendet wird.
' In den Zip-Dateien ist er jedoch zu finden.

' --------- Anfang Projektgruppe UclFontlistbox.sln  ---------
' -------- Anfang Projektdatei UclFontlistbox.vbproj  --------
' ------------ Anfang Datei frmUclFontlistbox.vb  ------------
Imports Microsoft.VisualBasic
Imports System
Imports System.io
Imports System.ComponentModel

Public Class frmUclFontlistbox

    Inherits System.Windows.Forms.Form

#Region " Vom Windows Form Designer generierter Code "

    Public Sub New()

        MyBase.New()
        InitializeComponent()

    End Sub

    ' Die Form überschreibt den Löschvorgang der Basisklasse, um Komponenten zu bereinigen.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)

        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If

        MyBase.Dispose(disposing)

    End Sub

    ' Für Windows Form-Designer erforderlich
    Private components As System.ComponentModel.IContainer

    ' HINWEIS: Die folgende Prozedur ist für den Windows Form-Designer erforderlich
    ' Sie kann mit dem Windows Form-Designer modifiziert werden.
    ' Verwenden Sie nicht den Code-Editor zur Bearbeitung.
    Friend WithEvents UclFontListbox1 As Fontlistbox.uclFontListbox
    Friend WithEvents btOk As System.Windows.Forms.Button
    Friend WithEvents Panel1 As System.Windows.Forms.Panel
    Friend WithEvents txtFontSize As System.Windows.Forms.TextBox
    Friend WithEvents Label1 As System.Windows.Forms.Label

    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()

        Me.btOk = New System.Windows.Forms.Button
        Me.UclFontListbox1 = New Fontlistbox.uclFontListbox
        Me.Panel1 = New System.Windows.Forms.Panel
        Me.txtFontSize = New System.Windows.Forms.TextBox
        Me.Label1 = New System.Windows.Forms.Label
        Me.Panel1.SuspendLayout()
        Me.SuspendLayout()

        '
        ' btOk
        '
        Me.btOk.Dock = System.Windows.Forms.DockStyle.Right
        Me.btOk.Location = New System.Drawing.Point(128, 0)
        Me.btOk.Name = "btOk"
        Me.btOk.Size = New System.Drawing.Size(48, 24)
        Me.btOk.TabIndex = 1
        Me.btOk.Text = "Ok"

        '
        ' UclFontListbox1
        '
        Me.UclFontListbox1.Dock = System.Windows.Forms.DockStyle.Fill

        Me.UclFontListbox1.Font = New System.Drawing.Font("Tahoma", 8.25!, _
            System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, _
            Byte))

        Me.UclFontListbox1.ItemFontSize = 8.0!
        Me.UclFontListbox1.Location = New System.Drawing.Point(0, 0)
        Me.UclFontListbox1.Name = "UclFontListbox1"
        Me.UclFontListbox1.Size = New System.Drawing.Size(176, 261)
        Me.UclFontListbox1.TabIndex = 3

        '
        ' Panel1
        '
        Me.Panel1.Controls.Add(Me.txtFontSize)
        Me.Panel1.Controls.Add(Me.Label1)
        Me.Panel1.Controls.Add(Me.btOk)
        Me.Panel1.Dock = System.Windows.Forms.DockStyle.Bottom
        Me.Panel1.Location = New System.Drawing.Point(0, 261)
        Me.Panel1.Name = "Panel1"
        Me.Panel1.Size = New System.Drawing.Size(176, 24)
        Me.Panel1.TabIndex = 4

        '
        ' txtFontSize
        '
        Me.txtFontSize.Dock = System.Windows.Forms.DockStyle.Fill
        Me.txtFontSize.Location = New System.Drawing.Point(80, 0)
        Me.txtFontSize.Name = "txtFontSize"
        Me.txtFontSize.Size = New System.Drawing.Size(48, 20)
        Me.txtFontSize.TabIndex = 0
        Me.txtFontSize.Text = "8"

        '
        ' Label1
        '
        Me.Label1.Dock = System.Windows.Forms.DockStyle.Left
        Me.Label1.Location = New System.Drawing.Point(0, 0)
        Me.Label1.Name = "Label1"
        Me.Label1.Size = New System.Drawing.Size(80, 24)
        Me.Label1.TabIndex = 2
        Me.Label1.Text = "ItemFontSize:"
        Me.Label1.TextAlign = System.Drawing.ContentAlignment.MiddleRight

        '
        ' frmUclFontlistbox
        '
        Me.AcceptButton = Me.btOk
        Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13)
        Me.ClientSize = New System.Drawing.Size(176, 285)
        Me.Controls.Add(Me.UclFontListbox1)
        Me.Controls.Add(Me.Panel1)
        Me.Name = "frmUclFontlistbox"
        Me.Text = "frmtestAADll"
        Me.Panel1.ResumeLayout(False)
        Me.ResumeLayout(False)

    End Sub

#End Region

    Private Sub btMakeBigger_Click(ByVal sender As Object, ByVal e As EventArgs) Handles btOk.Click

        Dim S As String = Me.txtFontSize.Text

        If IsNumeric(S) Then
            Me.UclFontListbox1.ItemFontSize = Single.Parse(S)
        End If

    End Sub

End Class

' ------------- Ende Datei frmUclFontlistbox.vb  -------------
' -------------- Anfang Datei uclFontListbox.vb --------------
Option Explicit On
Option Strict On
Option Compare Binary

Imports System
Imports System.Drawing
Imports System.Threading
Imports System.Windows.Forms
Imports System.ComponentModel

<ToolboxItem(True)> Public Class uclFontListbox

    Inherits System.Windows.Forms.UserControl

    Private Shared FontStyles As FontStyle() = DirectCast([Enum].GetValues(GetType( _
        FontStyle)), FontStyle())

    Private Shared _FontFamilies As FontFamily() = FontFamily.Families

    Private _ItemFontSize As Single
    Private _DataSource(-1) As Font

#Region " Vom Windows Form Designer generierter Code "

    Private components As System.ComponentModel.IContainer

    Friend WithEvents txtCurrentFont As System.Windows.Forms.TextBox
    Friend WithEvents lblSelectedFontName As System.Windows.Forms.Label

    <System.Diagnostics.DebuggerStepThrough()> _
        Private Sub InitializeComponent()

        Me.txtCurrentFont = New System.Windows.Forms.TextBox
        Me.lblSelectedFontName = New System.Windows.Forms.Label
        Me.ListBox1 = New System.Windows.Forms.ListBox
        Me.SuspendLayout()

        '
        ' txtCurrentFont
        '
        Me.txtCurrentFont.Dock = System.Windows.Forms.DockStyle.Top
        Me.txtCurrentFont.Location = New System.Drawing.Point(0, 0)
        Me.txtCurrentFont.Name = "txtCurrentFont"
        Me.txtCurrentFont.Size = New System.Drawing.Size(177, 21)
        Me.txtCurrentFont.TabIndex = 0

        '
        ' lblSelectedFontName
        '
        Me.lblSelectedFontName.Dock = System.Windows.Forms.DockStyle.Bottom
        Me.lblSelectedFontName.Location = New System.Drawing.Point(0, 216)
        Me.lblSelectedFontName.Name = "lblSelectedFontName"
        Me.lblSelectedFontName.Size = New System.Drawing.Size(177, 28)
        Me.lblSelectedFontName.TabIndex = 2
        Me.lblSelectedFontName.Text = "#"
        Me.lblSelectedFontName.TextAlign = System.Drawing.ContentAlignment.MiddleLeft

        '
        ' ListBox1
        '
        Me.ListBox1.Dock = System.Windows.Forms.DockStyle.Fill
        Me.ListBox1.DrawMode = System.Windows.Forms.DrawMode.OwnerDrawVariable
        Me.ListBox1.Location = New System.Drawing.Point(0, 21)
        Me.ListBox1.Name = "ListBox1"
        Me.ListBox1.Size = New System.Drawing.Size(177, 195)
        Me.ListBox1.TabIndex = 3

        '
        ' uclFontListbox
        '
        Me.Controls.Add(Me.ListBox1)
        Me.Controls.Add(Me.lblSelectedFontName)
        Me.Controls.Add(Me.txtCurrentFont)

        Me.Font = New System.Drawing.Font("Tahoma", 8.25!, System.Drawing.FontStyle.Regular, _
            System.Drawing.GraphicsUnit.Point, CType(0, Byte))

        Me.Name = "uclFontListbox"
        Me.Size = New System.Drawing.Size(177, 244)
        Me.ResumeLayout(False)
        Me.PerformLayout()

    End Sub

    Friend WithEvents ListBox1 As System.Windows.Forms.ListBox

#End Region

#Region "Init"

    Public Sub New()

        ReDim _DataSource(_FontFamilies.Length - 1)
        InitializeComponent()
        Me.lblSelectedFontName.DataBindings.Add("Text", _DataSource, "Name")
        Me.ItemFontSize = 12

    End Sub

#End Region ' Init

#Region "Events & Overrides"

    Private Sub txtCurrentFont_TextChanged(ByVal sender As Object, ByVal e As EventArgs) _
                Handles txtCurrentFont.TextChanged

        FindSimilar(txtCurrentFont.Text)

    End Sub

    Private Sub ListBox1_DrawItem(ByVal sender As Object, ByVal e As DrawItemEventArgs) _
                Handles ListBox1.DrawItem

        Dim fntCurrent As Font = _DataSource(e.Index)
        Dim DrawBrush As Brush

        e.DrawBackground()

        If (e.State And DrawItemState.Selected) = DrawItemState.Selected Then
            DrawBrush = SystemBrushes.HighlightText

        Else

            DrawBrush = SystemBrushes.WindowText
        End If

        e.Graphics.DrawString(fntCurrent.Name, fntCurrent, DrawBrush, e.Bounds.Left, _
            e.Bounds.Top + 1)

        If (e.State And DrawItemState.Focus) = DrawItemState.Focus Then
            e.DrawFocusRectangle()
        End If

    End Sub

    Private Sub ListBox1_MeasureItem(ByVal sender As Object, ByVal e As MeasureItemEventArgs) _
        Handles ListBox1.MeasureItem

        Dim fntCurrent As Font = _DataSource(e.Index)

        With e.Graphics.MeasureString(fntCurrent.Name, fntCurrent)
            e.ItemHeight = CInt(.Height) + 2
            e.ItemWidth = CInt(.Width)
        End With

    End Sub

    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)

        If disposing Then
            If Not (components Is Nothing) Then
                DisposeFonts()
                components.Dispose()
            End If
        End If

        MyBase.Dispose(disposing)

    End Sub

#End Region ' Events & Overrides

#Region "Publix"

    Public ReadOnly Property SelectedFont() As Font
        Get
            Return DirectCast(ListBox1.SelectedItem, Font)

        End Get

    End Property

    <Bindable(True), DefaultValue(12.0!), Category("Darstellung")> Public Property _
        ItemFontSize() As Single

        Get
            Return _ItemFontSize

        End Get

        Set(ByVal Value As Single)

            If _ItemFontSize = Value Then Return
            _ItemFontSize = Value
            Refill()

        End Set

    End Property

#End Region ' Publix

#Region "Privates"

    Private Sub DisposeFonts()

        For Each Ft As Font In _DataSource
            Ft.Dispose()
        Next

    End Sub

    Private Sub Refill()

        If Not (_DataSource(0) Is Nothing) Then
            DisposeFonts()
        End If

        For I As Integer = 0 To _DataSource.Length - 1
            For Each Style As FontStyle In FontStyles

                Dim fntFam As FontFamily = _FontFamilies(I)

                If fntFam.IsStyleAvailable(Style) Then

                    Dim Ft As New Font(fntFam, _ItemFontSize, Style, GraphicsUnit.Pixel)

                    _DataSource(I) = Ft

                    Exit For

                End If

            Next
        Next

        Me.ListBox1.DataSource = Nothing
        Me.ListBox1.DataSource = _DataSource

    End Sub

    ''' <summary>
    ''' selektiert den Font, dessen Name mit dem Pattern beginnt,
    ''' bei NichtFinden eines Matches den davor liegenden
    ''' </summary>
    Private Sub FindSimilar(ByVal Pattern As String)

        For I As Integer = 0 To _DataSource.Length - 1

            Select Case String.Compare(DirectCast(_DataSource(I), Font).Name, 0, Pattern, 0, _
                Pattern.Length, ignoreCase:=True)

                Case Is < 0
                Case 0
                    ListBox1.TopIndex = I
                    ListBox1.SelectedIndex = I
                    Return

                Case Is > 0

                    If I > 0 Then
                        ListBox1.TopIndex = I - 1
                        ListBox1.SelectedIndex = I - 1

                    Else

                        ListBox1.TopIndex = I
                        ListBox1.SelectedIndex = I
                    End If

                    Return

            End Select

        Next

    End Sub

#End Region ' Privates

End Class

' --------------- Ende Datei uclFontListbox.vb ---------------
' --------- Ende Projektdatei UclFontlistbox.vbproj  ---------
' ---------- Ende Projektgruppe UclFontlistbox.sln  ----------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.