|
Das deutsche QBasic- und FreeBASIC-Forum Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
Autor |
Nachricht |
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 01.03.2014, 15:59 Titel: [FreeType] Font Style auswählen? |
|
|
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 |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 03.03.2014, 03:18 Titel: |
|
|
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
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 |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1215 Wohnort: Ruhrpott
|
Verfasst am: 27.03.2014, 10:33 Titel: |
|
|
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 |
|
|
|
|
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.
|
|