Code-Beispiel

TrueTypeFonts für Draw String (nur Windows)

Lizenz:	Erster Autor:	Letzte Bearbeitung:
FBPSL	grindstone	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 grindstone angelegt.
Die aktuellste Version wurde am 03.10.2017 von grindstone gespeichert.
Bearbeiten
Versionen