Tipp-Upload: VB.NET 0337: Outlined und ziehbare Schrift

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Datenbanken und XML
• Grafik
• Listensteuerelemente
• Steuerelemente

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
ownerdrawing,outlining, outlined, Bindingsource,dataset

Der Vorschlag wurde erstellt am: 05.02.2009 15:02.
Die letzte Aktualisierung erfolgte am 05.02.2009 15:13.

Zurück zur Übersicht

Beschreibung  

Outlining zeichnet rings um die Schrift eine recht dicke Linie mit deutlichem HellDunkel-Kontrast zur Schrift. Dadurch wird die Schrift auf jedem Hintergrund lesbar.
Die grafischen Möglichkeiten einer WinForms-Anwendung reichen leider nicht für ein Outlining in guter Qualität.
Daher wird hier mit "Shadowing" gearbeitet: Die Schrift wird etwas versetzt in anderer Farbe gezeichnet. Ordnet man 8 solcher "Schatten" ringsum an, so hat man ebenfalls eine Umrahmung, und zusätzlich noch interessante Gestaltungs-Möglichkeiten hinsichtlich Versatz-Weite und Farbe.

Nun erweist sich das Gui, welches diese Gestaltungs-Möglichkeiten bereitstellt, als viel interessanter als das relativ triviale mehrfache und versetzte Zeichnen desselben Schriftzuges:
Man braucht mehrere Schriftzüge an verschiedenen Orten. Jeder Schriftzug hat mehrere Schatten, mit unterscheidlichem Versatz und Farbe.
Man will folgende Parameter einstellen können: Text, Font, Position, Farbe, Schatten-Anzahl, Schatten-Versatz, Schatten-Farbe.
Kurz und gut: Ein Fall für ein typisiertes Dataset mit zwei Tabellen.
Im UserCode-Bereich des Datasets (Kontextmenu Dataset: Code anzeigen) wird die TextRow zu einem Zeichen-Objekt erweitert.

Schwierigkeitsgrad

Verwendete API-Aufrufe:

Download: Download des Beispielprojektes [79,72 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 OutlinedText.sln  ----------
' --------- Anfang Projektdatei OutlinedText.vbproj  ---------
' ------------------ Anfang Datei Canvas.vb ------------------
Imports OutlinedText.MultiText
Imports System.ComponentModel
Imports System.Data
Imports System.Linq

Public Class Canvas

    Inherits Control

    Private WithEvents _TextSource As BindingSource = Nothing
    Private WithEvents _ShadeSource As BindingSource = Nothing
    Private WithEvents _Texts As TextDataTable
    Private WithEvents _Shades As ShadeDataTable

    ''' <summary>Differenz zw. Nullpunkt und Drag-Anfasspunkt</summary>
    ''' <remarks>
    ''' die Nullable-Struktur tranportiert zusätzlich die Information, 
    ''' ob _GrabOffset überhaupt gesetzt ist
    ''' </remarks>
    Private _GrabOffset As Nullable(Of Size)
    Private _MeasureGraphics As Graphics
    Private _topRank As Integer = 0

    Protected Overrides Sub OnParentChanged(ByVal e As System.EventArgs)

        MyBase.OnParentChanged(e)
        _MeasureGraphics = Me.CreateGraphics

    End Sub

    ''' <summary> im Designer einzustellen </summary>
    Public Property ShadeSource() As BindingSource
        Get
            Return _ShadeSource

        End Get

        Set(ByVal NewValue As BindingSource)

            ' Über die BindingSource der "Schatten" holt sich die Canvas die BindingSource
            ' der übergeordneten Texte
            _ShadeSource = NewValue

            _TextSource = If(_ShadeSource Is Nothing, Nothing, DirectCast( _
                _ShadeSource.DataSource, BindingSource))

        End Set

    End Property

    Private Sub _TextSource_ListChanged(ByVal sender As Object, ByVal e As _
        ListChangedEventArgs) Handles _TextSource.ListChanged

        ' hier werden die eigentlichen Tabellen geholt
        If e.ListChangedType = ListChangedType.Reset Then
            _Texts = DirectCast(_TextSource.DataSource, MultiText).Text
            _Shades = DirectCast(_TextSource.DataSource, MultiText).Shade
        End If

    End Sub

    Private _SelectedItem As TextRow = Nothing

    ''' <summary>
    ''' das selektierte Item. Es wird zuoberst (=zuletzt) und hervorgehoben gezeichnet
    ''' </summary>
    Public Property SelectedItem() As TextRow
        Get
            Return _SelectedItem

        End Get

        Private Set(ByVal NewValue As TextRow)

            ' Die TextSource ist nach "Rank" sortiert.
            ' Indem newItem.Rank den Maximalwert bekommt wird es ans Ende sortiert und fertig
            If _SelectedItem Is NewValue Then Return
            If _SelectedItem IsNot Nothing Then Me.InvalidateX(_SelectedItem.Bounds)
            _SelectedItem = NewValue

            If _SelectedItem Is Nothing Then Return
            _topRank += 1
            _SelectedItem.Rank = _topRank
            _TextSource.Position = _TextSource.Count - 1

        End Set

    End Property

    Private _ItemUnderMouse As TextRow = Nothing

    ''' <summary> das aktuell unter der Maus befindliche Item - sonst Nothing </summary>
    Public Property ItemUnderMouse() As TextRow
        Get
            Return _ItemUnderMouse

        End Get

        Private Set(ByVal NewValue As TextRow)

            If _ItemUnderMouse Is NewValue Then Return
            _ItemUnderMouse = NewValue
            Me.Cursor = If(_ItemUnderMouse Is Nothing, Cursors.Default, Cursors.Hand)

        End Set

    End Property

    Protected Overrides Sub OnPaint(ByVal e As PaintEventArgs)

        MyBase.OnPaint(e)

        If _TextSource Is Nothing OrElse _TextSource.Count = 0 Then Return

        Dim rw As TextRow = Nothing

        For Each rw In _TextSource.GetRows(Of TextRow)()
            rw.Draw(e.Graphics)
        Next

        e.Graphics.DrawRectangle(Pens.Red, rw.Bounds.InflateX(-1, -1))

    End Sub

    Protected Overrides Sub OnMouseDown(ByVal e As MouseEventArgs)

        MyBase.OnMouseDown(e)

        If ItemUnderMouse Is Nothing Then Return

        ' Draggen des Texts starten
        SelectedItem = ItemUnderMouse
        _GrabOffset = New Size(e.Location - New Size(SelectedItem.Location))

    End Sub

    Protected Overrides Sub OnMouseMove(ByVal e As MouseEventArgs)

        MyBase.OnMouseMove(e)

        If _Texts Is Nothing Then Return

        ' entweder draggen oder ItemUnderMouse feststellen
        If _GrabOffset.HasValue Then

            Dim pt = e.Location - _GrabOffset.Value

            If _SelectedItem.Location.Equals(pt) Then Return
            _SelectedItem.Location = pt

        Else

            ' rückwärts durchlaufen (von "oben" nach "unten")
            For i = _TextSource.Count - 1 To 0 Step -1

                Dim rw = _TextSource.At(Of TextRow)(i)

                If rw.Bounds.Contains(e.Location) Then
                    ItemUnderMouse = rw
                    Return
                End If

            Next

            ItemUnderMouse = Nothing
        End If

    End Sub

    ''' <summary>Draggen beenden</summary>
    Protected Overrides Sub OnMouseUp(ByVal e As MouseEventArgs)

        MyBase.OnMouseUp(e)
        _GrabOffset = Nothing

    End Sub

    Private Sub _Texts_TextRowChanged(ByVal sender As Object, ByVal e As _
        MultiText.TextRowChangeEvent) Handles _Texts.TextRowChanged, _Texts.TextRowDeleting

        Select Case e.Action

            Case DataRowAction.Add
                _Shades.AddShadeRow(Size.Empty, Me.ForeColor, e.Row)
                _Shades.AddShadeRow(New Size(-2, 0), Color.Yellow, e.Row)
                SelectedItem = e.Row

            Case DataRowAction.Change
                Me.InvalidateX(e.Row.Bounds)
                e.Row.UpdateBounds(_MeasureGraphics) ' löst ggfs. erneutes TextRowChanged aus

            Case DataRowAction.Delete

                Dim i = _TextSource.Count - 2

                SelectedItem = If(i < 0, Nothing, _TextSource.At(Of TextRow)(i))

        End Select

    End Sub

    Private Sub _Shades_ShadeRowChanged(ByVal sender As Object, ByVal e As _
        MultiText.ShadeRowChangeEvent) Handles _Shades.ShadeRowChanged, _
        _Shades.ShadeRowDeleting

        If Not CBool(e.Action And (DataRowAction.Add Or DataRowAction.Change Or _
            DataRowAction.Delete)) Then Return

        Dim rwTxt = e.Row.TextRow

        Me.InvalidateX(rwTxt.Bounds)
        rwTxt.UpdateBounds(_MeasureGraphics)

    End Sub

    Private Sub _Texts_TableNewRow(ByVal sender As Object, ByVal e As _
        DataTableNewRowEventArgs) Handles _Texts.TableNewRow

        With DirectCast(e.Row, TextRow)
            .Text = "New Item" & .TextID
            .Location = Point.Empty
            .Bounds = Rectangle.Empty
            .Font = Me.Font
        End With

    End Sub

    Private Sub _Shades_TableNewRow(ByVal sender As Object, ByVal e As _
        DataTableNewRowEventArgs) Handles _Shades.TableNewRow

        With DirectCast(e.Row, ShadeRow)
            .Color = Me.ForeColor
            .Offset = Size.Empty
        End With

    End Sub

End Class

' ------------------- Ende Datei Canvas.vb -------------------
' ------------------ Anfang Datei Form1.vb  ------------------
Imports OutlinedText.MultiText

Public Class Form1

    Private Sub TextBox1_TextChanged(ByVal sender As Object, ByVal e As EventArgs) Handles _
        TextBox1.TextChanged

        ' Databinding der Textbox kann die Datasource nicht bei jeder Textänderung updaten.
        ' Daher habich im Designer beim Binden der Textbox unter erweiterten Einstellungen
        ' DataSourceUpdatemode.Never eingestellt, und update händisch im TextChanged-Event
        TextSource.At(Of TextRow)().Text = TextBox1.Text
        TextSource.EndEdit()

    End Sub

    Private Sub MenuStrip1_MenuClicked(ByVal Sender As Object, ByVal e As EventArgs) _
           Handles AddTextToolStripMenuItem.Click, RemoveTextToolStripMenuItem.Click

        Select Case True

            Case Sender Is AddTextToolStripMenuItem
                TextSource.AddNew()
                TextSource.EndEdit()

            Case Sender Is RemoveTextToolStripMenuItem
                TextSource.RemoveAt(TextSource.Count - 1)

        End Select

    End Sub

    Private Sub TextSource_CurrentChanged(ByVal sender As Object, ByVal e As EventArgs) _
        Handles TextSource.CurrentChanged

        ' Enablität diverser Controls updaten
        Dim EnableValue = TextSource.Count > 0

        If Me.RemoveTextToolStripMenuItem.Enabled.Assign(EnableValue) Then

            For Each ctl In New Control() {TextBox1, btFont, ShadeGrid}
                ctl.Enabled = EnableValue
            Next

        End If

    End Sub

    Private Sub btFont_Click(ByVal sender As Object, ByVal e As EventArgs) Handles btFont.Click

        With Me.FontDialog1

            Dim rw = TextSource.At(Of TextRow)()

            .Font = rw.Font

            If .ShowDialog = Windows.Forms.DialogResult.OK Then
                rw.Font = .Font
            End If

        End With

    End Sub

    Private Sub ShadeGrid_CellClick(ByVal sender As Object, ByVal e As _
        DataGridViewCellEventArgs) Handles ShadeGrid.CellClick

        If e.RowIndex < 0 OrElse e.ColumnIndex < 0 Then Return
        If ShadeGrid.CurrentCell.ValueType.Equals(GetType(Color)) Then

            ' wird in eine Farb-Zelle geklickst, den ColorDialog abfahren
            With Me.ColorDialog1

                If .ShowDialog = Windows.Forms.DialogResult.OK Then
                    ShadeSource.At(Of ShadeRow).Color = .Color
                    ShadeSource.EndEdit()
                End If

            End With

        End If

    End Sub

    Private Sub Form1_Load(ByVal sender As Object, ByVal e As EventArgs) Handles Me.Load

        Dim FT = New Font(Me.Canvas21.Font.FontFamily, 20, FontStyle.Bold Or FontStyle.Italic)

        Dim rwTxt = Me.MultiText.Text.AddTextRow("My first Item", 0, New Point(40, 0), FT, _
            Rectangle.Empty)

        ' vorgenerierten ersten Schatten modifizieren und weitere Schatten hinzufügen, bis
        ' ringsum verschattet ist (8 Schatten)
        Const Offs As Integer = 2
        rwTxt.GetShadeRows(1).Offset = New Size(Offs, Offs)

        With Me.MultiText.Shade
            .AddShadeRow(New Size(Offs, 0), Color.Yellow, rwTxt)
            .AddShadeRow(New Size(Offs, -Offs), Color.Yellow, rwTxt)
            .AddShadeRow(New Size(0, Offs), Color.Yellow, rwTxt)
            .AddShadeRow(New Size(0, -Offs), Color.Yellow, rwTxt)
            .AddShadeRow(New Size(-Offs, Offs), Color.Yellow, rwTxt)
            .AddShadeRow(New Size(-Offs, 0), Color.Yellow, rwTxt)
            .AddShadeRow(New Size(-Offs, -Offs), Color.Yellow, rwTxt)
        End With

        TextSource.Sort = "Rank"

    End Sub

End Class

' ------------------- Ende Datei Form1.vb  -------------------
' ---------------- Anfang Datei Extensions.vb ----------------
Imports System.Runtime.CompilerServices
Imports System.Drawing

Public Module Extensions

    ''' <summary>
    ''' korrigiere Control.Invalidate(Rectangle.Empty) - Fehldesign: Da wird nämlich das ganze Control invalidiert
    ''' </summary>
    <Extension()> _
        Public Sub InvalidateX(ByVal subj As Control, ByVal rct As Rectangle)

        If rct.Width = 0 OrElse rct.Height = 0 Then Return
        subj.Invalidate(rct)

    End Sub

    ''' <summary>
    ''' returnt die typisierte Datarow am index. Bei ungültigem index Nothing (keine OutOfRange-Exception!)
    ''' </summary>
    <Extension()> Public Function At(Of T As DataRow)(ByVal subj As BindingSource, Optional _
        ByVal index As Integer = -1) As T

        If index < 0 Then index = subj.Position
        If index >= 0 AndAlso index < subj.Count Then
            Return DirectCast(DirectCast(subj(index), DataRowView).Row, T)
        End If

        Return Nothing

    End Function

    ''' <summary> returnt eine typisierte Enumeration aller Datarows </summary>
    <Extension()> _
        Public Function GetRows(Of T As DataRow)(ByVal subj As BindingSource) As IEnumerable(Of T)

        Return subj.Cast(Of DataRowView).Select(Function(drv) DirectCast(drv.Row, T))

    End Function

    ''' <summary> testet vor einer Zuweisung, ob der neue Wert überhaupt eine Änderung bringt </summary>
    ''' <remarks>
    ''' nützlich bei Zuweisungen an performance-intensive Properties, 
    ''' oder wenn auf Änderungen reagiert werden muß
    ''' </remarks>
    <Extension()> _
        Public Function Assign(Of T, T2 As T)(ByRef Dest As T, ByVal Src As T2) As Boolean

        If Object.Equals(Dest, Src) Then Return False
        Dest = Src
        Return True

    End Function

    <Extension()> _
        Public Function IsSomething(Of T As Class)(ByVal Subj As T) As Boolean

        Return Subj IsNot Nothing

    End Function

End Module

' ----------------- Ende Datei Extensions.vb -----------------
' ---------------- Anfang Datei MultiText.vb  ----------------

Partial Class MultiText

    Partial Class TextRow

        ' Die typisierte TextRow wird zum Zeichen-Objekt erweitert

        Private Shared _DrawBrush As New SolidBrush(Color.Black)

        Public Sub Draw(ByVal G As Graphics)

            Dim Shades = Me.GetShadeRows

            ' rückwärts durchlaufen - Erster "Schatten" ist der Zentral-Text, und als
            ' letztes zu zeichnen
            For I = Shades.Count - 1 To 0 Step -1
                _DrawBrush.Color.Assign(Shades(I).Color)
                G.DrawString(Me.Text, Me.Font, _DrawBrush, Me.Location + Shades(I).Offset)
            Next

        End Sub

        Public Sub UpdateBounds(ByVal G As Graphics)

            ' Die Bounds bestehen aus der ausgemessenen Schrift zuzüglich maximalem Versatz
            ' aller Schatten (in 4 Richtungen)
            Dim OffsMin, OffsMax As Size
            Dim Shades = Me.GetShadeRows

            For Each rwSh In Shades

                With rwSh.Offset

                    If .Width < OffsMin.Width Then
                        OffsMin.Width = .Width

                    ElseIf .Width > OffsMax.Width Then

                        OffsMax.Width = .Width
                    End If

                    If .Height < OffsMin.Height Then
                        OffsMin.Height = .Height

                    ElseIf .Height > OffsMax.Height Then

                        OffsMax.Height = .Height
                    End If

                End With

            Next

            Dim SzF = G.MeasureString(Me.Text, Me.Font, Short.MaxValue)
            Dim rct = (New RectangleF(Me.Location + OffsMin, SzF + OffsMax - OffsMin)).CeilingX

            If rct.Equals(Me.Bounds) Then Return
            Me.Bounds = rct ' Dieses löst DataBinding-Events aus!!

        End Sub

    End Class
End Class

' ----------------- Ende Datei MultiText.vb  -----------------
' ---------- Ende Projektdatei OutlinedText.vbproj  ----------
' ----------- Ende Projektgruppe OutlinedText.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.