Buchempfehlung
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Umfassend, aber leicht verständlich führt dieses Buch in die Programmierung von ATMEL AVR Mikrocontrollern ein. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Grafik und Fonts

TrueTypeFonts für Draw String (nur Windows)

Lizenz:Erster Autor:Letzte Bearbeitung:
FBPSLMitgliedgrindstone 03.10.2017

Hier ein weiterer Ansatz, die eingebauten TrueTypeFonts für Draw String nutzbar zu machen, mit einigen Anwendungsbeispielen. Die gewünschten Fonteigenschaften werden per UDT-Variable tFontInfo an die Funktion MakeTTFimage übergeben, die einen Pointer auf das erstellte Fontimage zurückgibt. Das Rendern der Buchstaben übernimmt das Bertiebssystem.

#Include Once "windows.bi"
#Include Once "fbgfx.bi"

Type tFontInfo
  As ULong textcolor       = RGB(255, 255, 255)
  As ULong background      = RGB(255, 0, 255) 'transparent
  As ULong Height          = 15
  As ULong Wid             = 0
  As ULong Escapement      = 0
  As ULong Orientation     = 0
  As ULong Weight          = FW_NORMAL
  As BOOL Italic           = FALSE
  As BOOL Underline        = FALSE
  As BOOL StrikeOut        = FALSE
  As ULong CharSet         = ANSI_CHARSET
  As ULong OutputPrecision = OUT_RASTER_PRECIS
  As ULong ClipPrecision   = CLIP_DEFAULT_PRECIS
  As ULong Quality         = DEFAULT_QUALITY
  As ULong PitchAndFamily  = FIXED_PITCH Or FF_DONTCARE
  As String FontName       = "Arial"
End Type

Function MakeTTFimage(info As tFontInfo) As UByte Ptr
    Dim As Integer totalwidth, x, myFontPtr, depth, dcIndex
    Dim As UByte Ptr myFont, p
    Dim As String text, driver
    Dim As fb.image Ptr characterPtr
    Dim As HDC hdc, bitmap_dc
    Dim As HFONT hFont
    Dim As HBITMAP bitmap
    Dim As BITMAPINFO BitmapInfo
    Dim As TEXTMETRIC txmet

    ReDim As ABC charwid(0)
    ReDim As ULong wid(0)

    ScreenInfo ,,depth,,,,driver
    If (depth <> 32) Or (driver = "") Then
        Return 0 'function failed
    EndIf

    With info
        hFont = CreateFont(.Height, .Wid, .Escapement, .Orientation, .Weight,  .Italic, _
                           .Underline, .StrikeOut, .CharSet, .OutputPrecision, _
                           .ClipPrecision, .Quality, .PitchAndFamily, StrPtr(.FontName))

        hdc = GetDC(NULL)
        dcIndex = SaveDC(hdc)
        bitmap_dc = CreateCompatibleDC(hdc)
        SelectObject(bitmap_dc, hFont)
        SetBkColor(bitmap_dc, RGBA(LoByte(LoWord(.background)), HiByte(LoWord(.background)), _
                                   LoByte(HiWord(.background)), 0))
        SetTextColor(bitmap_dc, RGBA(LoByte(LoWord(.textcolor)), HiByte(LoWord(.textcolor)), _
                                     LoByte(HiWord(.textcolor)), 0))
    End With

    GetTextMetrics(bitmap_dc, @txmet)
    With txmet
        ReDim charwid(.tmFirstChar To .tmLastChar)
        ReDim wid(.tmFirstChar To .tmLastChar)

        GetCharABCWidths(bitmap_dc, .tmFirstChar, .tmLastChar, @charwid(.tmFirstChar))

        For x = LBound(charwid) To UBound(charwid) 'calculate width of every character
            wid(x) = charwid(x).abcA + charwid(x).abcB + charwid(x).abcC
            wid(x) = IIf(wid(x) < 1, charwid(x).abcB, wid(x))
            totalwidth += wid(x)
        Next
        myFont = ImageCreate(totalwidth, .tmHeight + 1, info.background, 32) 'create font image

        p = myFont
        p += IIf(myFont[0] = 7, 32, 4) 'points to font header
        p[0] = 0 'fontversion is always 0
        p[1] = .tmFirstChar
        p[2] = .tmLastChar

        bitmap = CreateCompatibleBitmap(hdc, .tmMaxCharWidth, .tmHeight + 1)
        SelectObject(bitmap_dc, bitmap)
        With BitmapInfo.bmiHeader
            .biSize     = SizeOf(BITMAPINFOHEADER)
            .biHeight   = -(txmet.tmHeight + 1)
            .biPlanes   = 1
            .biBitCount = 32
        End With
        For x = .tmFirstChar To .tmLastChar
          p[3 + x - .tmFirstChar] = wid(x) 'write character width to 1st line of font image
          TextOut(bitmap_dc, 0, 0, Chr(x), 1) 'write character to bitmap context
            characterPtr = ImageCreate(wid(x), .tmHeight + 1, info.background, 32) 'create character image buffer
          characterPtr->pitch = characterPtr->Width * 4 'set correct pitch
            BitmapInfo.bmiHeader.biWidth = wid(x) 'set character width
            getdibits(bitmap_dc, bitmap, 0, .tmHeight + 1, characterPtr + 1, @BitmapInfo, DIB_RGB_COLORS) 'grab character image
            Put myfont, (myFontPtr, 1), characterPtr, PSet 'add character image to font image
            myFontPtr += wid(x) 'next character's x position in font image
            ImageDestroy(characterPtr)
        Next
    End With

    RestoreDC(hdc, dcIndex)
    DeleteObject(hfont)
    DeleteObject(bitmap)
    ReleaseDC(NULL, hdc)
    ReleaseDC(NULL, bitmap_dc)

    Return myFont
End Function

Function EnumFontFamProc(lpelf As ENUMLOGFONT Ptr, lpntm As NEWTEXTMETRIC Ptr, dwType As ULong, lpdata As lParam) As ULong
    'slideshow of all available TT-fonts
    Dim As tFontInfo dsfont
    Static As String fname
    Dim As UByte Ptr myFont

    If dwType = TRUETYPE_FONTTYPE Then
        If (lpelf->elfFullName <> fname) Then
            fname = lpelf->elfFullName
            dsfont.fontName = fname
            dsfont.textcolor = RGB(0,0,0)
            Line (0,300)-(800,480), RGB(255,255,255),BF

            dsfont.height = 50
            myFont = MakeTTFimage(dsfont)
            Draw String(50,300), fname + " " + Str(dsfont.height),,myFont
            ImageDestroy myFont

            dsfont.height = 40
            myFont = MakeTTFimage(dsfont)
            Draw String(60,340), fname + " " + Str(dsfont.height),,myFont
            ImageDestroy myFont

            dsfont.height = 30
            myFont = MakeTTFimage(dsfont)
            Draw String(70,375), fname + " " + Str(dsfont.height),,myFont
            ImageDestroy myFont

            dsfont.height = 20
            myFont = MakeTTFimage(dsfont)
            Draw String(80,405), fname + " " + Str(dsfont.height),,myFont
            ImageDestroy myFont

            dsfont.height = 15
            myFont = MakeTTFimage(dsfont)
            Draw String(90,428), fname + " " + Str(dsfont.height),,myFont
            ImageDestroy myFont

            dsfont.height = 10
            myFont = MakeTTFimage(dsfont)
            Draw String(100,450), fname + " " + Str(dsfont.height),,myFont
            ImageDestroy myFont

            Sleep 3000
            If InKey <> "" Then
                Return FALSE
            EndIf
        EndIf
    EndIf

    Return TRUE
End Function

'-----------------------------------------------
Dim As UByte Ptr myFont, myFont2, myFont3, myFont4, myFont5, myFont6
Dim As String text
Dim As Integer x
Dim As HDC hdc
Dim As tFontInfo dsfont, default

ScreenRes 800, 600, 32

'some examples
myFont = MakeTTFimage(dsfont)
Draw String(10,10), "Hello world",,myFont

dsfont.height = 20
myFont2 = MakeTTFimage(dsfont)
Draw String(10,20), "Hello world",,myFont2

dsfont.FontName = "Times New Roman"
myFont3 = MakeTTFimage(dsfont)
Draw String(10,35), "Hello world",,myFont3

dsfont.weight = FW_BOLD
myFont4 = MakeTTFimage(dsfont)
Draw String(10,50), "Hello world",,myFont4

dsfont.height = 30
dsfont.underline = TRUE
myFont5 = MakeTTFimage(dsfont)
Draw String(10,65), "Hello world",,myFont5

dsfont.textcolor = RGB(255,0,0)
dsfont.background = RGB(0,255,0)
dsfont.underline = FALSE
dsfont.italic = TRUE
myFont6 = MakeTTFimage(dsfont)
Draw String(10,100), "Hello world",,myFont6

ImageDestroy(myfont)
dsfont = default
myFont = MakeTTFimage(dsfont)
Draw String(10,140), "Hello world",,myFont

ImageDestroy(myfont)
dsfont.height = 30
myFont = MakeTTFimage(dsfont)
Draw String(10,150), "Hello world",,myFont

ImageDestroy(myfont)
dsfont.height = 70
dsfont.fontName = "Blackletter686 BT"
myFont = MakeTTFimage(dsfont)
Draw String(10,170), "Hello world",,myFont

ImageDestroy(myfont)
dsfont.height = 50
dsfont.textcolor = RGB(255, 255, 0)
dsfont.background = RGB(255, 0, 0)
dsfont.fontName = "OldDreadfulNo7 BT"
myFont = MakeTTFimage(dsfont)
Draw String(10,240), "Hello world",,myFont

dsfont = default

ImageDestroy(myfont)
dsfont.textcolor = RGB(0,255,0)
dsfont.height = 50
dsfont.fontName = "Times New Roman"
dsfont.weight = FW_HEAVY
myFont = MakeTTFimage(dsfont)
Draw String(150,0), "TrueType Fonts for Draw String",,myFont

ImageDestroy(myfont)
dsfont.textcolor = RGB(0,255,0)
dsfont.italic = TRUE
dsfont.wid = 40
myFont = MakeTTFimage(dsfont)
Draw String(250,50), "Hello world",,myFont

ImageDestroy(myfont)
dsfont.textcolor = RGB(0,0,255)
dsfont.height = 20
dsfont.italic = FALSE
dsfont.underline = TRUE
dsfont.escapement = 50
dsfont.wid = 40
dsfont.weight = FW_THIN
myFont = MakeTTFimage(dsfont)
Draw String(300,100), "Hello world",,myFont

ImageDestroy(myfont)
dsfont.textcolor = RGB(0,0,255)
dsfont.background = RGB(255,255,0)
dsfont.underline = FALSE
dsfont.strikeout = TRUE
dsfont.escapement = 0
dsfont.wid = 10
dsfont.weight = FW_THIN
myFont = MakeTTFimage(dsfont)
Draw String(350,150), "Hello world",,myFont

dsfont = default
ImageDestroy(myFont)
Swap dsfont.textcolor, dsfont.background
dsfont.height = 100
dsfont.fontName = "Times New Roman"
myFont = MakeTTFimage(dsfont)
Draw String(250,190), "Hello world!!!",,myFont

Randomize
For x = -50 To 900 Step 20
    Dim As ULong col = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
    For y As Integer = 0 To 20
        Line (x + y,480)-(x + y + 50, 600), col
    Next
Next

ImageDestroy(myFont)
Swap dsfont.textcolor, dsfont.background
dsfont.height = 80
dsfont.textcolor = RGB(255,0,255)
dsfont.background = RGB(0,0,0)
dsfont.fontName = "Broadway BT"
myFont = MakeTTFimage(dsfont)
Draw String(160,500), "Transparent",,myFont

ImageDestroy(myFont)
ImageDestroy(myFont2)
ImageDestroy(myFont3)
ImageDestroy(myFont4)
ImageDestroy(myFont5)
ImageDestroy(myFont6)

'show all available TT fonts
hdc = getDC(NULL)
If EnumFontFamilies(hdc, NULL, Cast(FONTENUMPROC, @EnumFontFamProc), NULL) = TRUE Then
    Sleep 3000
EndIf
ReleaseDC(NULL, hdc)

Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 20.09.2017 von Mitgliedgrindstone angelegt.
  • Die aktuellste Version wurde am 03.10.2017 von Mitgliedgrindstone gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen