Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

[FreeType] Font Style auswählen?

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Bibliotheken
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 01.03.2014, 14:59    Titel: [FreeType] Font Style auswählen? Antworten mit Zitat

Ich spiele gerade ein wenig mit FreeType im Zusammenhang mit diesem Thread herum...

Code:
#include "freetype2/freetype.bi"

''FreeType Init
Namespace FType
    Dim as FT_Library library
    Dim as Integer    IsInit   , IsFont
    Dim as Integer    sizesmall, sizebig
    Dim as FT_Face    fontsmall, fontbig
    Dim as String     textsmall, textbig
    Dim as ubyte ptr  ttfmask
   
    Function TTFLoad(byval TTFFile as String) as Integer
        If (IsInit = 0) then
            If (FT_Init_FreeType(@library) <> 0) Then
                IsFont = 0 : IsInit = 0
                Return 0
            End If
            IsInit = -1
        End If
       
        If (FT_New_Face(library, TTFFile, 0, @fontbig) <> 0) Then IsFont = 0 : return 0
        If (FT_New_Face(library, TTFFile, 0, @fontsmall) <> 0) Then IsFont = 0 : return 0

        IsFont = -1
        return -1
    End Function
   
    Function setTTFFontSize(byval size as Integer) as Integer
        If (IsInit = 0) or (IsFont = 0) Then return 0
        If (FT_Set_Pixel_Sizes(fontbig, size, size) <> 0) Then sizebig = 0 : Return 0
        If (FT_Set_Pixel_Sizes(fontsmall, size*.5, size*.5) <> 0) Then sizesmall = 0 : Return 0
        sizebig = size : sizesmall = size*.5
        return -1
    End Function
   
    '' bigOrsmall (0|1)
    Function getTTFStringSize(byval bigORsmall as Integer, byref ttfWidth as Integer, byref ttfHeight as Integer) as Integer
        If (IsInit = 0) or (IsFont = 0) Then return 0
        Dim as Integer   lensmall  = Len(textsmall)
        Dim as Integer   lenbig    = len(textbig)
        Dim as Integer   tmpHeightsmall, tmpHeightbig, stmp, btmp
        Dim as Integer   tmpWidthsmall , tmpWidthbig
        Dim as FT_UInt   index
       
        If (bigORsmall = 0) Then
            For l as Integer = 0 to lenbig-1
                index = FT_Get_Char_Index(fontbig, textbig[l])
           
                If (FT_Load_Glyph(fontbig, index, FT_LOAD_RENDER) <> 0) Then Return 0
           
                'font->glyph->bitmap_top
                tmpHeightbig = fontbig->glyph->bitmap.rows
                tmpWidthbig += fontbig->glyph->advance.x shr 6
                If tmpHeightbig>btmp Then btmp=tmpHeightbig
            Next l
            ttfWidth  = tmpWidthbig
            ttfHeight = btmp
        Else
            For l as Integer = 0 to lensmall-1
                index = FT_Get_Char_Index(fontsmall, textsmall[l])
           
                If (FT_Load_Glyph(fontsmall, index, FT_LOAD_RENDER) <> 0) Then Return 0
           
                'font->glyph->bitmap_top
                tmpHeightsmall = fontsmall->glyph->bitmap.rows
                tmpWidthsmall += fontsmall->glyph->advance.x shr 6
                If tmpHeightsmall>stmp Then stmp=tmpHeightsmall
            Next l
            ttfWidth  = tmpWidthsmall
            ttfHeight = stmp
        End If
        return -1
    End Function
   
    Function TTFString2Mask(byval mapwidth as integer, byval mapheight as integer) as Integer
        If (IsInit = 0) or (IsFont = 0) Then return 0
        If ttfmask Then deallocate(ttfmask) : ttfmask = 0
       
        Dim as Integer        addx, addy, intx, inty
        Dim as Integer        stringlen
        Dim as FT_UInt        index
        Dim As FT_Bitmap Ptr  bitmap
       
        ttfmask = callocate(mapwidth*mapheight)
       
        getTTFStringSize(0,intx,inty)
        addy=(mapheight*.5)+(inty*.125)
        addx=(mapwidth*.5)-(intx*.5)
       
        stringlen = len(textbig)
        For l as Integer = 0 to stringlen-1
            index = FT_Get_Char_Index(fontbig, textbig[l])
           
            If (FT_Load_Glyph(fontbig, index, FT_LOAD_RENDER) <> 0) Then
                Return 0
            End If           
           
            bitmap = @fontbig->glyph->bitmap
            For y as Integer = 0 to bitmap -> rows-1
                inty =  addy + y - fontbig->glyph->bitmap_top
            For x as Integer = 0 to bitmap -> width-1
                intx = addx + fontbig->glyph->bitmap_left + x
                if (intx>-1) and (intx<mapwidth) and (inty>-1) and (inty<mapheight) Then ttfmask[intx+(inty*mapwidth)]=bitmap->buffer[y * bitmap->pitch + x]
            Next x
            Next y
            addx += fontbig->glyph->advance.x shr 6
        Next l
       
        getTTFStringSize(1,intx,inty)
        addy=(mapheight*.5)+(inty*1.7)
        addx=(mapwidth*.5)-(intx*.5)
       
        stringlen = len(textsmall)
        For l as Integer = 0 to stringlen-1
            index = FT_Get_Char_Index(fontsmall, textsmall[l])
           
            If (FT_Load_Glyph(fontsmall, index, FT_LOAD_RENDER) <> 0) Then
                Return 0
            End If           
           
            bitmap = @fontsmall->glyph->bitmap
            For y as Integer = 0 to bitmap -> rows-1
                inty =  addy + y - fontsmall->glyph->bitmap_top
            For x as Integer = 0 to bitmap -> width-1
                intx = addx + fontsmall->glyph->bitmap_left + x
                if (intx>-1) and (intx<mapwidth) and (inty>-1) and (inty<mapheight) Then ttfmask[intx+(inty*mapwidth)]=bitmap->buffer[y * bitmap->pitch + x]
            Next x
            Next y
            addx += fontsmall->glyph->advance.x shr 6
        Next l
       
        return -1
    End Function
End Namespace


''**************************************************


FType.textbig = "FreeBASIC"
FType.textsmall = "EternalPain"

FType.TTFLoad(Environ("windir") & "\Fonts\Arial.ttf")
FType.setTTFFontSize(40)
FType.TTFString2Mask(500,100)

screenres 500,100,32

If FType.ttfmask Then
    Dim z as Integer
    For y as Integer = 0 to 99
    For x as Integer = 0 to 499
        z=FType.ttfmask[x+(y*500)]
        If z then pset (x,y),rgb(z,z,z)
    next x
    next y
End If
sleep


''**************************************************


Nun suche ich noch nach einer Möglichkeit den Font nach Wunsch auch Fett und/oder Italic darzustellen.
Hab schon ein wenig gegoogelt, allerdings bisher ohne wirklich viel Erfolg.

Jemand eine Idee?
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 03.03.2014, 02:18    Titel: Antworten mit Zitat

Bin immernoch damit am experimentieren und erstmal zu den ergebnis gekommen das FreeType das ganze so einfach nicht kann...
Daher suche ich eine Umleitung über die WinAPI

Code:
#include "windows.bi"

''Callback
Function EnumFontFamiliesExProc(byval lpelfe as ENUMLOGFONTEX ptr, byval lpntme as NEWTEXTMETRICEX ptr, byval FontType as Integer, byval lParam as LPARAM) as Integer
    'Dim as Integer c
    If (FontType and TRUETYPE_FONTTYPE)=TRUETYPE_FONTTYPE andalso bit(lpntme->ntmTm.ntmFlags,6) Then 'Print "Typ   : TrueType-Font";
        'c = Len(lpelfe->elfLogFont.lfFaceName)
        'If c andalso lpelfe->elfLogFont.lfFaceName[0]<>64 Then Print lpelfe->elfLogFont.lfFaceName'Print *cast(zstring ptr,@lpelfe->elfFullName(0))
        If lpelfe->elfLogFont.lfFaceName[0]<>64 Then Print lpelfe->elfLogFont.lfFaceName
       
    End If

    return 1
End Function

Dim as HDC hDC = GetDC(NULL)
Dim as LOGFONT lf
lf.lfCharSet = ANSI_CHARSET'DEFAULT_CHARSET
EnumFontFamiliesEx( hDC, @lf, cast(any ptr,@EnumFontFamiliesExProc), 0, 0 )
ReleaseDC( NULL, hDC )
sleep

Mit diesem experiment kann ich mir immerhin schon die vollen Namen der installierten Fonts ausgeben...

Habe dann mithilfe von google versucht einen font zu laden (was auch klappt) und diesen zu zeichnen, was nicht wirklich klappt (nur auf dem Desktop)
Code:
''http://www.functionx.com/win32/Lesson15.htm
#Include "windows.bi"
#include "fbgfx.bi"
screenres 320,240,32

Dim as HWND hWnd '= GetDesktopWindow()
Screencontrol fb.GET_WINDOW_HANDLE, cast(integer,hWnd)

Dim as PAINTSTRUCT ps
Dim as HDC hDC
Dim as HFONT font
Dim as LPRECT fbRect
'hDC = getWindowDC(hWnd)
'hDC = BeginPaint(hWnd, @Ps)
hDC = getDC(NULL)

Dim as LOGFONT LogFont
        LogFont.lfHeight = 80    'Größe
        LogFont.lfEscapement = 0 '??
        LogFont.lfFaceName = "Mephisto" & chr(153) 'Schrift Familie
        '**********************************'
        LogFont.lfItalic    = FALSE       ''Kursiv          (TRUE|FALSE)
        LogFont.lfWeight    = FW_REGULAR  ''Fett            (FW_BOLD|FW_REGULAR)
        LogFont.lfUnderline = FALSE       ''Unterstrichen   (TRUE|FALSE)
        LogFont.lfStrikeOut = FALSE       ''Durchgestrichen (TRUE|FALSE)
       
        font = CreateFontIndirect(@LogFont)
       
        SelectObject(hDC, font)
        '-> bmp -> dip ?????
        TextOut(hDC, 0, 0, "Test 1234", 9)
        DeleteObject(font)
        '**********************************'       
        LogFont.lfItalic = FALSE
        LogFont.lfWeight = FW_BOLD
       
        font = CreateFontIndirect(@LogFont)
       
        SelectObject(hDC, font)
        '-> bmp -> dip ?????
        TextOut(hDC, 0,100, "Test 1234", 9)
        DeleteObject(font)
        '**********************************'     
        LogFont.lfItalic = TRUE
        LogFont.lfWeight = FW_REGULAR
       
        font = CreateFontIndirect(@LogFont)
       
        SelectObject(hDC, font)
        '-> bmp -> dip ?????
        TextOut(hDC, 0,200, "Test 1234", 9)
        DeleteObject(font)
        '**********************************'     
'EndPaint(hWnd, @Ps)
sleep


Nun suche ich natürlich einen Weg das ganze mit FreeType zu verknüpfen oder damit etwas vergleichbares zu basteln... kann man irgendwie in ein array 'zeichnen' mit TextOut oder vergleichbares? in eine Bitmap oder so?

Edit:
habe ein Beispiel gefunden, welches bei mir aber scheinbar nicht funktioniert...
Code:
'http://stackoverflow.com/questions/18877254/how-to-draw-text-to-byte-array-using-winapi
#include "windows.bi"
#include "fbgfx.bi"

dim as integer w = 1024
dim as integer h = 768

screenres w,h,32

dim as HWND hWnd '= GetDesktopWindow()
Screencontrol fb.GET_WINDOW_HANDLE, cast(integer,hWnd)
?hWnd
dim as HDC hdc = getDC(hWnd)'GetDC( g_hWnd );  /// g_hWnd is my windows handle type HWND
?hdc

Dim as ubyte ptr buf = new ubyte[w*h]
?buf

Dim as HDC vhdc = CreateCompatibleDC(hdc)
?vhdc
'if vhdc = 0 Then ?"error with vhdc"

Dim as HBITMAP hbmp = CreateCompatibleBitmap( hdc, w, h )
?hbmp

Dim as BITMAPINFO bmpi = type(type<BITMAPINFOHEADER>(sizeof(BITMAPINFOHEADER),w,-h,1,32,BI_RGB,0,0,0,0,0),{0,0,0,0})
SelectObject( vhdc, hbmp )
TextOut( vhdc, 10, 10, "HELLO WORLD", 11 )
GetDIBits(vhdc, hbmp, 0, h, buf, @bmpi, BI_RGB)


Dim as Integer c
for y as integer = 0 to h-1
for x as integer = 0 to w-1
    c=buf[x+(y*w)]
    if c then ?c;'pset(x,y),rgb(c,c,c)
next x
next y
?"..."
sleep


Edit2:
Scheint doch zu funktionieren lächeln
Code:

'http://stackoverflow.com/questions/18877254/how-to-draw-text-to-byte-array-using-winapi
#include "windows.bi"
#include "fbgfx.bi"

dim as integer w = 640
dim as integer h = 480

screenres w,h,32

dim as HWND hWnd = GetDesktopWindow()
'Screencontrol fb.GET_WINDOW_HANDLE, cast(integer,hWnd)

dim as HDC hdc = GetWindowDC(hWnd)
Dim as uinteger ptr buf = new uinteger[w*h]
Dim as HDC vhdc = CreateCompatibleDC(hdc)
Dim as HBITMAP hbmp = CreateCompatibleBitmap(hdc, w, h)
Dim as BITMAPINFO bmpi = type(type<BITMAPINFOHEADER>(sizeof(BITMAPINFOHEADER),w,-h,1,32,BI_RGB,0,0,0,0,0),{0,0,0,0})

Dim as HFONT font
Dim as LOGFONT LogFont
        LogFont.lfHeight = 80    'Größe
        LogFont.lfEscapement = 0 '??
        LogFont.lfFaceName = "Times New Roman" 'Schrift Familie
        '**********************************'
        LogFont.lfItalic    = TRUE        ''Kursiv          (TRUE|FALSE)
        LogFont.lfWeight    = FW_REGULAR  ''Fett            (FW_BOLD|FW_REGULAR)
        LogFont.lfUnderline = FALSE       ''Unterstrichen   (TRUE|FALSE)
        LogFont.lfStrikeOut = FALSE       ''Durchgestrichen (TRUE|FALSE)
       
        font = CreateFontIndirect(@LogFont)
       
SelectObject(vhdc, font)
SelectObject(vhdc, hbmp)

SetBkMode(vhdc, &h000000)
SetTextColor(vhdc, &hFFFFFF)

TextOut(vhdc, 0, 0, "HELLO WORLD", 11)

GetDIBits(vhdc, hbmp, 0, h, buf, @bmpi, DIB_RGB_COLORS)

DeleteObject(font)
DeleteObject(hbmp)
DeleteDC(vhdc)
ReleaseDC(hWnd, hdc)

Dim as Integer c
for y as integer = 0 to h-1
for x as integer = 0 to w-1
    c=buf[x+(y*w)]
    if c then pset(x,y),c
next x
next y

sleep

_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 680
Wohnort: Ruhrpott

BeitragVerfasst am: 27.03.2014, 09:33    Titel: Antworten mit Zitat

Eternal_pain hat Folgendes geschrieben:
Nun suche ich noch nach einer Möglichkeit den Font nach Wunsch auch Fett und/oder Italic darzustellen.

Die Methode aus dem letzten Post ist da meiner bescheidenen Meinung nach sehr viel praktischer, aber wenn es trotzdem jemand mit FreeType versuchen möchte:

normal:.........FType.TTFLoad(Environ("windir") & "\Fonts\Arial.ttf")
kursiv:...........FType.TTFLoad(Environ("windir") & "\Fonts\Ariali.ttf")
fett:...............FType.TTFLoad(Environ("windir") & "\Fonts\Arialbd.ttf")
fett + kursiv:.FType.TTFLoad(Environ("windir") & "\Fonts\Arialbi.ttf")

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Bibliotheken Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz