vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Sch?tzen Sie Ihre Software vor Software-Piraterie - mit sevLock 1.0 DLL!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Grafik und Font · Font & Text   |   VB-Versionen: VB5, VB624.10.06
Ausgabe von Text, antialiased

Tipp, der zeigt, wie man Text antialiased auf verschiedene Arten auf einer Form oder in einer Picturebox ausgeben kann

Autor:   Dietrich HerrmannBewertung:     [ Jetzt bewerten ]Views:  12.681 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Der nachfolgende Tipp zeigt Ihnen in einem Beispielprojekt, wie man Text antialiased auf verschiedene Arten auf einer Form oder in einer Picturebox ausgeben kann.
Damit erreicht man ein sehr schönes Schriftbild ohne die sonst allgegenwärtigen "Pixeltreppen" bei Textdarstellungen insbesondere bei großen Schriften.

Der Tipp beinhaltet nachfolgende Funktionen:

  • CreateFontA: Erzeugen des Texts antialiased oder nicht, rotiert oder nicht
  • OutputTextAliased: Funktion für die Ausgabe des Texts
  • OutCircleText: Ausgabe eines Texts im Halbkreis
  • OutWavedText: Ausgabe eines Texts an einer Sinuskurve
  • DrawCenteredRotatedText: Hilfsfunktion - Text am 'Zeichen-Mittelpunkt' gedreht
  • OutTextBlockshadow: Text mit Blockschatten ausgeben
  • OutOutlineText: Erzeugen von Outline-Text

Damit hat man einige Möglichkeiten zur Gestaltung von Textausgaben.
Wenn der Text anklickbar sein soll, muss man die Ausgabe in die Picturebox wählen. Dann kann man auch Texteffekte beim Klicken anwenden, wie im Beispiel gezeigt.

Ich habe in dieser Lösung auch einige andere Tipps und Quellen verarbeitet und danke dafür:  http://vb-helper.com/howto_draw_outlined_text_wo_api.html
 http://vb-helper.com/howto_center_rotated_text.html
 www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=37273&lngWId=1

Zunächst der Code, den man in einem Modul unterbringen sollte:

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function SelectObject Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal hObject As Long) As Long
 
Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName(1 To 32) As Byte
End Type
 
Private Declare Function TextOut Lib "gdi32" _
  Alias "TextOutA" ( _
  ByVal hdc As Long, _
  ByVal X As Long, _
  ByVal Y As Long, _
  ByVal lpString As String, _
  ByVal nCount As Long) As Long
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
  Alias "CreateFontIndirectA" ( _
  lpLogFont As LOGFONT) As Long
 
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
 
Private Declare Function CreateFont Lib "gdi32" _
  Alias "CreateFontA" ( _
  ByVal H As Long, _
  ByVal w As Long, _
  ByVal E As Long, _
  ByVal O As Long, _
  ByVal w As Long, _
  ByVal I As Long, _
  ByVal u As Long, _
  ByVal s As Long, _
  ByVal C As Long, _
  ByVal OP As Long, _
  ByVal CP As Long, _
  ByVal Q As Long, _
  ByVal PAF As Long, _
  ByVal F As String) As Long
 
Private Declare Function DeleteObject Lib "gdi32" ( _
  ByVal hObject As Long) As Long
 
' Font weight constants.
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_ULTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_DEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_ULTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const FW_BLACK = 900
 
' Character set constants.
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const OEM_CHARSET = 255
 
' Output precision constants.
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
 
' Clipping precision constants.
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_EMBEDDED = &H80
Private Const CLIP_LH_ANGLES = &H10
Private Const CLIP_TO_PATH = 4097
Private Const CLIP_TT_ALWAYS = &H20
 
' Character quality constants.
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
Private Const NONANTIALIASED_QUALITY = 3
Private Const ANTIALIASED_QUALITY = 4
 
' Pitch and family constants.
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
Private Const TRUETYPE_FONTTYPE = &H4
Private Const FF_DECORATIVE = 80  '  Old English, etc.
Private Const FF_DONTCARE = 0     '  Don't care or don't know.
Private Const FF_MODERN = 48      '  Constant stroke width, serifed 
                                  '  or sans-serifed.
Private Const FF_ROMAN = 16       '  Variable stroke width, serifed.
Private Const FF_SCRIPT = 64      '  Cursive, etc.
Private Const FF_SWISS = 32       '  Variable stroke width, sans-serifed.
 
Private Const LF_FACESIZE = 32
 
Private Const PI = 3.14159265358979
Private Const PI_OVER_2 = PI / 2
 
Public hMasterFont As Long

Hier folgen nun die speziellen oben angeführten Funktionen, die Sie ebenfalls in das Modul einfügen:

' Erzeugen des Texts antialiased oder nicht, rotiert oder nicht
' neue Properties:
' FontWidth- Zeichen in der Breite verändern
' FontAliased- Darstellung des Texts aliased oder nicht (True/False)
' FontRotation- drehen des Texts um einen Winkel (Werte >=0 und <361)
Public Function CreateFontA(FontName As String, FontSize As Integer, _
  Optional FontBold As Integer = FW_BOLD, _
  Optional FontItalic As Boolean = False, _
  Optional FontUnderline As Boolean = False, _
  Optional FontWidth As Integer = 0, _
  Optional FontAliased As Boolean = True, _
  Optional FontRotation As Integer = 0) As Long
 
  On Error Resume Next
  Dim plf As LOGFONT, I As Long
 
  FontName = Trim(FontName)
  FontName = FontName + String(32 - Len(FontName), 0)
  For I = 1 To 32
    plf.lfFaceName(I) = Asc(Mid(FontName, I, 1))
  Next I
  ' Height
  plf.lfHeight = CLng(FontSize)
  ' Width
  plf.lfWidth = CLng(FontWidth)
  ' Bold, Underline, Italic
  plf.lfWeight = FontBold
  plf.lfUnderline = FontUnderline
  plf.lfItalic = FontItalic
  ' Anti Aliasing
  If FontAliased Then
    plf.lfQuality = ANTIALIASED_QUALITY
  Else
    plf.lfQuality = NONANTIALIASED_QUALITY
  End If
  If FontRotation >= 0 And FontRotation < 361 Then _
    plf.lfEscapement = CLng(FontRotation) * 10
 
  CreateFontA = CreateFontIndirect(plf)
End Function
' Ausgabe des Texts
' obj- kann die Form oder eine Picturebox sein
' theText- der auszugebende Text
' x- x-Position des Textes in Pixel
' y- y-Position des Textes in Pixel
' clipFormPic- True, wenn in der für den Text verwendeten Picturebox 
'    als Hintergrund das Bild der Form erscheinen soll
' fo- die Form, wenn clipFormPic True ist
' position- es kann angegeben werden, ob der Text im Objekt 
'   (Form/Picturebox) horizontal(h), vertikal(v) oder zentriert(z) 
'   ausgegeben werden soll
Public Sub outputTextAliased(obj As Variant, _
  theText As String, X As Long, Y As Long, _
  Optional clipFormPic As Boolean = False, _
  Optional fo As Form, _
  Optional position As String, _
  Optional delFont As Boolean = True)
 
  Dim hfntprev As Long, I As Long, hFnt As Long
 
  If TypeOf obj Is PictureBox Then
    obj.Cls
    If clipFormPic Then
      obj.PaintPicture fo.Picture, 0, 0, obj.Width, obj.Height, _
        obj.Left, obj.Top, obj.Width, obj.Height
      obj.Picture = obj.Image
    End If
  End If
 
  hfntprev = SelectObject(obj.hdc, hMasterFont)
 
  If position = "h" Or position = "z" Then _
    X = (obj.ScaleWidth - obj.TextWidth(theText)) / 2
  If position = "v" Or position = "z" Then _
    Y = (obj.ScaleHeight - obj.TextHeight(theText)) / 2
  TextOut obj.hdc, X, Y, theText, Len(theText)
  If delFont Then DeleteObject hMasterFont
  If TypeOf obj Is PictureBox Then obj.Refresh
End Sub
' Ausgabe Text im Halbkreis
' die Länge des Textes bestimmt den Radius des Halbkreises
Public Sub outCircleText(obj As Variant, theText As String, _
  X As Long, Y As Long, _
  FontName As String, FontSize As Integer, _
  Optional FontBold As Integer = FW_BOLD, _
  Optional FontItalic As Boolean = False, _
  Optional FontUnderline As Boolean = False, _
  Optional FontWidth As Integer = 0, _
  Optional FontAliased As Boolean = True)
 
  Dim currX&, currY&
  Dim I%, tWidth%, z$
  Static radius%
  Dim winkelConst, anfConst, angle, anglet
 
  obj.FontSize = FontSize
  tWidth = obj.TextWidth(theText) ' Textbreite ist Halbumfang
  radius = tWidth / PI            ' Radius berechnen aus halbem Umfang
 
  winkelConst = Int(180 / (Len(theText) * 2 - 1) * 2)
  anfConst = 0
  If Len(theText) Mod 2 <> 0 Then
    ' ungerade Anzahl von Zeichen
    anfConst = winkelConst / 2
  Else
    ' gerade Anzahl
    winkelConst = Int(180 / ((Len(theText) - 1) * 2 - 1) * 2)
  End If
 
  ' Berechnen der Winkelwerte
  For I = 0 To Len(theText) - 1
    z = Mid(theText, I + 1, 1)
    angle = (180 - I * winkelConst) - anfConst
    If I < Len(theText) / 2 Then
      anglet = Abs(angle - 90)
    Else
      anglet = angle + 270
    End If
    currX = X + radius * Cos(angle * PI / 180)
    currY = Y - radius * Sin(angle * PI / 180)
    ' erzeugen des rotierten Textes
    ' aus berechnetem Mittelpunkt jedes einzelnen Zeichens
    DrawCenteredRotatedText obj, z, currX, currY, FontName, _
      FontSize, anglet
  Next I
End Sub
' Text an einer Sinuskurve
' neue Parameter:
' drawAbove- soll der Text über der Sinuskurve dargestellt werden?
' drawCurve- die Sinuskurve kann mitgezeichnete werden oder nicht
Public Sub outWavedText(obj As Variant, theText As String, _
  X As Double, Y As Double, _
  FontName As String, FontSize As Integer, _
  Optional FontBold As Integer = FW_BOLD, _
  Optional FontItalic As Boolean = False, _
  Optional FontUnderline As Boolean = False, _
  Optional FontWidth As Integer = 0, _
  Optional FontAliased As Boolean = True, _
  Optional drawAbove As Boolean, _
  Optional drawCurve As Boolean = False)
 
  Dim I As Integer
  Dim z As String
  Dim y_offset As Double
  Dim X1 As Double
  Dim y1 As Double
  Dim x2 As Double
  Dim y2 As Double
  Const faktor = 15
 
  hMasterFont = CreateFontA(FontName, FontSize, , , , , True, 0)
 
  obj.FontSize = FontSize
  y_offset = 0
  If drawAbove Then y_offset = -obj.TextHeight(theText)
 
  X1 = X
  y1 = Sin(X1 / FontSize / 2) * faktor + Y
  x2 = X1
  y2 = y1
 
  For I = 1 To Len(theText)
    z = Mid$(theText, I, 1)
 
    outputTextAliased obj, z, Round(x2), Round(y2 + y_offset)
    ' Draw the line on the curve if desired
    If drawCurve Then obj.Line (X1, y1)-(x2, y2)
 
    ' Move to the next point
    X1 = x2
    y1 = y2
    x2 = x2 + obj.TextWidth(z)
    y2 = Sin(x2 / 17) * faktor + Y
  Next I
  DeleteObject hMasterFont
End Sub
' Text am 'Mittelpunkt' gedreht
' der Text wird zeichenweise ausgegeben
' dabei wird zu jedem Zeichen dessen 'Mittelpunkt' und
' das umschreibende Rechteck
' neue Parameter:
' angle- der vorgegebene Winkel für jedes Zeichen
Public Sub DrawCenteredRotatedText(obj As Variant, _
  theText As String, X As Long, Y As Long, _
  FontName As String, FontSize As Integer, _
  angle As Variant)
 
  Dim wid As Double
  Dim hgt As Double
  Dim wx As Double
  Dim wy As Double
  Dim hx As Double
  Dim hy As Double
  Dim theta As Double
  Dim ox As Double
  Dim oy As Double
 
  hMasterFont = CreateFontA(FontName, FontSize, , , , , , Round(angle))
 
  ' ermitteln der Textbreite
  wid = obj.TextWidth(theText)
 
  ' konvertieren der Schrifthöhe von Points into...
  hgt = obj.ScaleY(FontSize, vbPoints, obj.ScaleMode)
 
  theta = -angle * PI / 180 ' negativ, weil y wächst nach unten
  wx = wid * Cos(theta) / 2
  wy = wid * Sin(theta) / 2
  hx = -hgt * Sin(theta) / 2
  hy = hgt * Cos(theta) / 2
 
  ' ermitteln des Rotationspunktes
  ox = X - wx - hx
  oy = Y - wy - hy
 
  ' ausgeben des Texts, respektive ein Zeichen
  outputTextAliased obj, theText, Round(ox), Round(oy)
  DeleteObject hMasterFont
 
  ' ' zeichnen des Mittelpunkts
  ' obj.Circle (X, Y), 4, vbWhite
  '
  ' ' zeichnen des umschreibenden Rechtecks
  ' obj.CurrentX = X - wx - hx
  ' obj.CurrentY = Y - wy - hy
  ' obj.Line -(X + wx - hx, Y + wy - hy), vbBlue
  ' obj.Line -(X + wx + hx, Y + wy + hy), vbBlue
  ' obj.Line -(X - wx + hx, Y - wy + hy), vbBlue
  ' obj.Line -(X - wx - hx, Y - wy - hy), vbBlue
End Sub
' Text mit Blockschatten ausgeben
' neue Parameter:
' shadoWWidth- die Breite des Schattens in Pixel
' shadowColor- die Farbe des Schattens
' shadowDirection- Angabe, wo der Schatten erscheinen soll
' (lu- left,upper; ru- right,upper; lb- left,bottom; rb- right,bottom
' l- left only; r- right only; u- upper only, b- bottom only)
Public Sub outTextBlockshadow(obj As Variant, theText As String, _
  X As Long, Y As Long, _
  FontName As String, FontSize As Integer, _
  Optional FontBold As Integer = FW_BOLD, _
  Optional FontItalic As Boolean = False, _
  Optional FontUnderline As Boolean = False, _
  Optional FontWidth As Integer = 0, _
  Optional FontAliased As Boolean = True, _
  Optional FontRotation As Integer = 0, _
  Optional shadowWidth As Integer = 5, _
  Optional shadowColor As Long = vbBlack, _
  Optional shadowDirection = "lb")
 
  Dim I%, objColor&, rx%, ry%
 
  Select Case shadowDirection
    Case "lu"
        rx = -1: ry = -1
    Case "ru"
        rx = 1: ry = -1
    Case "lb"
        rx = -1: ry = 1
    Case "rb"
        rx = 1: ry = 1
    Case "l"
        rx = -1: ry = 0
    Case "r"
        rx = 1: ry = 0
    Case "u"
        rx = 0: ry = -1
    Case "b"
        rx = 0: ry = 1
  End Select
  objColor = obj.ForeColor
  obj.ForeColor = shadowColor
  hMasterFont = CreateFontA(FontName, FontSize, FontBold, FontItalic, _
    FontUnderline, FontWidth, FontAliased, FontRotation)
  For I = 1 To shadowWidth
    outputTextAliased obj, theText, X + rx * I, Y + ry * I
  Next I
  obj.ForeColor = objColor
  outputTextAliased obj, theText, X, Y
  DeleteObject hMasterFont
End Sub
' Erzeugen von Outline-Text
' neue Parameter:
' outLineColor- die Farbe der Randlinie
' textColor- die 'innere' Farbe des Texts
' borderWid- die Breite der Randlinie in Pixel
Public Sub outOutlineText(obj As Variant, theText As String, _
  X As Long, Y As Long, _
  FontName As String, FontSize As Integer, _
  Optional FontBold As Integer = FW_BOLD, _
  Optional FontItalic As Boolean = False, _
  Optional FontUnderline As Boolean = False, _
  Optional FontWidth As Integer = 0, _
  Optional FontAliased As Boolean = True, _
  Optional FontRotation As Integer = 0, _
  Optional outlineColor As Long, _
  Optional textColor As Long, _
  Optional borderWid As Integer = 1)
 
  Dim I As Integer
  Dim j As Integer
  Dim pixx As Single
  Dim pixy As Single
  Dim currX As Long
  Dim currY As Long
 
  ' Ausgabe der Randlinie duchr ausgeben des Texts,
  ' der in alle Richtungen um 1 Pixel versetzt wird
  pixx = obj.ScaleX(1, vbPixels, obj.ScaleMode)
  pixy = obj.ScaleY(1, vbPixels, obj.ScaleMode)
  obj.ForeColor = outlineColor
  hMasterFont = CreateFontA(FontName, FontSize, FontBold, FontItalic, _
    FontUnderline, FontWidth, FontAliased, FontRotation)
  For I = -borderWid To borderWid
    For j = -borderWid To borderWid
      currX = X + I * pixx
      currY = Y + j * pixy
      outputTextAliased obj, theText, currX, currY
    Next j
  Next I
  DeleteObject hMasterFont
 
  ' ausgeben des Texts
  obj.ForeColor = textColor
  hMasterFont = CreateFontA(FontName, FontSize, FontBold, FontItalic, _
    FontUnderline, FontWidth, FontAliased, FontRotation)
  outputTextAliased obj, theText, X, Y
  DeleteObject hMasterFont
End Sub

Die Aufrufe der Funktionen erfolgt folgendermaßen (ich schreibe hier genau diejenigen Aufrufe hin, die im Beispielprojekt verwendet wurden).
Sie müssen selbst entscheiden, an welcher Stelle Ihres Programms Sie sie einsetzen.

Me.Cls
Picture1.Cls
 
hMasterFont = CreateFontA("Arial", 24, , , 1, , True, 0)
outputTextAliased Me, "Beispiele für die Darstellung von " & _
  Text antialiased...", 80, 40
 
Me.ForeColor = vbWhite
hMasterFont = CreateFontA("Arial", 96, , 1, , , True, 0)
outputTextAliased Me, "Form", 20, 100
 
hMasterFont = CreateFontA("Times New Roman", 42, , , , 26, True, 45)
outputTextAliased Picture1, "PictureBox", 0, 200, True, Me
Picture1.Visible = True
 
Me.ForeColor = vbBlack
hMasterFont = CreateFontA("Arial", 84, , 1, , , True, 0)
outputTextAliased Me, "Toll!", 483, 233
Me.ForeColor = vbYellow
hMasterFont = CreateFontA("Arial", 84, , 1, , , True, 0)
outputTextAliased Me, "Toll!", 480, 230
 
Me.ForeColor = vbGreen
outCircleText Me, "Halbkreis", Me.ScaleWidth / 4 + 50, _
  Me.ScaleHeight * 3 / 5 + 120, "Arial", 56
 
Me.ForeColor = vbBlack
outWavedText Me, "sinuskurventext", Me.ScaleWidth / 3 + 150, _
  Me.ScaleHeight * 3 / 4 - 50, "Arial", 34
 
Me.ForeColor = vbBlack
outTextBlockshadow Me, "BLOCKshadow", Me.ScaleWidth / 3 + 150, _
  Me.ScaleHeight * 3 / 4 + 50, "Verdana", 42, , , , , True, , , _
  vbCyan, "lb"
 
outTextBlockshadow Me, "Outline", 20, 200, "times", 66, , , , , , , 5, _
  vbWhite, "lu"
outOutlineText Me, "Outline", 20, 200, "times", 66, , , , , , , _
  vbYellow, vbBlack
 
outOutlineText Me, "rotate", 20, 300, "arial", 66, , True, , , , 20, _
  vbYellow, vbBlue
 
outTextBlockshadow Me, "VERTICAL", 600, 200, "arial", 40, , , , , , _
  90, 10, vbRed, "ru"
outOutlineText Me, "VERTICAL", 600, 200, "arial", 40, , , , , , 90, _
  vbWhite, vbBlack

Nun… viel Spaß beim Gestalten Ihrer Bildschirmtexte!
Nebenbei gesagt: Diese Textausgabe kann gewiss auch mit paar Modifikationen aufs Printer-Objekt angewendet werden...
 

Dieser Tipp wurde bereits 12.681 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel