Rubrik: Grafik und Font · Font & Text | VB-Versionen: VB5, VB6 | 24.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 Herrmann | Bewertung: | Views: 14.718 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | 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...