 |
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 |
zwergnase
Anmeldungsdatum: 03.01.2006
Beiträge: 26
Wohnort: Frankfurt am Main
|
 Verfasst am: 01.08.2006, 18:31 Titel: Fonts unter FreeBASIC |
 |
|
Tach,
Weis einer von euch wie man Schriften in freebasic benutzt?
Martin |
|
| Nach oben |
|
 |
Kai Bareis
Anmeldungsdatum: 10.09.2004
Beiträge: 545
Wohnort: Baden Würtemberg
|
| Verfasst am: 01.08.2006, 18:46 Titel: |
|
|
also wenn du recht einfach TTF Fonts in FB verwenden willst solltest du die einmal http://www.freebasic.net/forum/viewtopic.php?t=1713&highlight=gfxlibttf
den Thread anschauen. Funktioniert soweit recht gut.
_________________
MfG Kai Bareis
Es ist noch kein Meister vom Himmel gefallen! Warum einfach wens auch umständlich geht! |
|
| Nach oben |
|
|
oldirty
Anmeldungsdatum: 04.08.2005
Beiträge: 65
|
| Verfasst am: 01.08.2006, 19:37 Titel: |
|
|
Hallo,
hier nochmals ein Tip: da ab der Version 0.17b vom 22.07.2006 die Einbindung der libgfxlibttf.a nicht mehr funktioniert (wird über die gfxlibttf.bi gemacht, Prg. lässt sich dann nicht mehr compilieren):
Code als SUB_ttf.bas abspeichern und über
| Code: |
#include once "SUB_TTF.bas"
|
mit ins Programm einbinden (anstelle der o. g. lib).
Info:
muss nach dem Screen-Aufruf ausgeführt werden.
Dann alles Weitere wie aus demo ersichtlich verwenden.
| Code: |
'Umgestaltet am 25/07/06 (Nur Zeile 6 und Zeile 17-20), damit diese Version als
'SUB_ttf.bas in alle Programme (ohne Verwendung der libgfxlibttf.a, da diese
'ab Version 0.17 vom 22/07/06 nicht mehr geht.
'Björn Hamcke
Option Explicit
#include once "windows.bi"
'#include "gfxlibttf.bi"
#include once "externs.bi"
Enum FontOptionsEnum
Bold = &b1
Italic = &b10
Underline = &b100
StrikeThrough = &b1000
AntiAliased = &b10000
End Enum
'Declare Function FormatMessage Alias "FormatMessageA" _
' (ByVal dwFlags As DWORD, ByVal lpSource As LPCVOID, ByVal dwMessageId As DWORD, _
' ByVal dwLanguageId As DWORD, ByVal lpBuffer As LPTSTR, ByVal nSize As DWORD, _
' ByVal Arguments As Any Ptr) As DWORD
Declare Function PrintFont(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal TextColor As uInteger = 0, ByVal ReturnSprite As Integer = 0) As Integer
Declare Function SetFont(ByVal FontName As String = "Arial", ByVal FontSize As uInteger = 12, ByVal FontOptions As uInteger = 0) As HFONT
Declare Function PrintFontSm(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal TextColor As uInteger = 0, ByVal ReturnSprite As Integer = 0) As Integer
Declare Function InitTTF As Integer
Declare Function GetTextWidth(ByVal Text As String)
Dim Shared BitmapV4Header As BitmapV4Header
Dim Shared MemBMP As HBITMAP
Dim Shared MemDC As HDC
Dim Shared MemSprite As Any Ptr
Dim Shared IsItalic As BOOL
Function InitTTF As Integer
Dim BitmapPalette As LOGPALETTE Ptr
' Set up BitmapV4Header for ARGB:
With BitmapV4Header
.bV4Size = SizeOf(BitmapV4Header)
.bV4Width = FB_Mode->Width
.bV4Height = -FB_Mode->Height
.bV4Planes = 1
.bV4BitCount = 32
.bV4V4Compression = BI_BITFIELDS
.bV4SizeImage = FB_Mode->Width * FB_Mode->Height * 4
.bV4XPelsPerMeter = 1
.bV4YPelsPerMeter = 1
.bV4ClrUsed = 0
.bV4ClrImportant = 0
End With
' Create Memory Bitmap
MemDC = CreateCompatibleDC( GetDC(FB_Win32.Wnd))
MemBMP = CreateCompatibleBitmap( GetDC(FB_Win32.Wnd), FB_Mode->Width, FB_Mode->Height)
SelectObject MemDC, MemBMP
SetBkColor MemDC, Rgb(255, 0, 255)
SetBkMode(MemDC, TRANSPARENT)
PrintFont -999, -999, ".", Rgb(0, 0, 0)
If cInt(MemDC) And cInt(MemBMP) Then Return TRUE
End Function
Function SetFont(ByVal FontName As String = "Arial", ByVal FontSize As uInteger = 12, ByVal FontOptions As uInteger = 0) As HFONT
Dim nHeight As uInteger
Dim nWidth As uInteger
Dim nEscapement As uInteger
Dim nOrientation As uInteger
Dim fnWeight As uInteger
Dim fdwItalic As uInteger
Dim fdwUnderline As uInteger
Dim fdwStrikeOut As uInteger
Dim fdwCharSet As uInteger
Dim fdwOutputPrecision As uInteger
Dim fdwClipPrecision As uInteger
Dim fdwQuality As uInteger
Dim fdwPitchAndFamily As uInteger
Dim hFont As HFONT
Dim hDC As HDC
hDC = GetDC(FB_Win32.Wnd)
nHeight = -MulDiv(FontSize, GetDeviceCaps(hDC, LOGPIXELSY), 72)' "pt" sized
nWidth = 0
nEscapement = NULL
nOrientation = NULL
If FontOptions And Bold Then fnWeight = 700 Else fnWeight = 100
If FontOptions And Italic Then fdwItalic = TRUE
If FontOptions And Italic Then IsItalic = TRUE Else IsItalic = FALSE
If FontOptions And Underline Then fdwUnderline = TRUE
If FontOptions And StrikeThrough Then fdwStrikeOut = TRUE
fdwQuality = ANTIALIASED_QUALITY
fdwCharSet = NULL
fdwOutputPrecision = NULL
fdwClipPrecision = NULL
fdwQuality = NULL
fdwPitchAndFamily = NULL
hFont = CreateFont( _
nHeight, _
nWidth, _
nEscapement, _
nOrientation, _
fnWeight, _
fdwItalic, _
fdwUnderline, _
fdwStrikeOut, _
fdwCharSet, _
fdwOutputPrecision, _
fdwClipPrecision, _
fdwQuality, _
fdwPitchAndFamily, _
StrPtr(FontName) _
)
DeleteObject SelectObject(MemDC, hFont)
Return hFont
End Function
Function PrintFontSm(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal TextColor As uInteger = 0, ByVal ReturnSprite As Integer = 0) As Integer
Dim TextSize As SIZE
Dim Sprite As Any Ptr
Dim SpriteData As uByte Ptr
Dim NewSprite As uByte Ptr
Dim NewRect As RECT
Dim ReturnSpriteA As Any Ptr
Dim As Integer cx, cy
ReturnSpriteA = cPtr(Any Ptr, ReturnSprite)
'Calculate Width And Height
GetTextExtentPoint32 MemDC, StrPtr(Text), Len(Text), @TextSize
If TextSize.cx + x > FB_Mode->Width Then TextSize.cx = FB_Mode->Width - x
If TextSize.cy + y > FB_Mode->Height Then TextSize.cy = FB_Mode->Height - y
Sprite = ImageCreate(TextSize.cx, TextSize.cy)
NewRect.Right = TextSize.cx
NewRect.Bottom = TextSize.cy
'Copy To Sprite
With BitmapV4Header
.bV4Width = TextSize.cx
.bV4Height = -TextSize.cy
.bV4SizeImage = TextSize.cx * TextSize.cy * 4
End With
SetTextColor MemDC, TextColor
SetBkMode MemDC, OPAQUE
TextOut MemDC, 0, 0, StrPtr(Text), Len(Text)
SetBkMode MemDC, TRANSPARENT
GetDIBits MemDC, MemBMP, 0, TextSize.cy, Sprite + 4, cPtr(BITMAPINFO Ptr, @BITMAPV4HEADER), DIB_RGB_COLORS
If ReturnSprite = 0 Then
'PUT On Screen
Put (x, y), Sprite, TRANS
ImageDestroy Sprite
Return TRUE
Else
Put ReturnSpriteA, (x, y), Sprite, PSET
ImageDestroy Sprite
Return TRUE
End If
End Function
Function PrintFont(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal TextColor As uInteger, ByVal ReturnSprite As Integer = 0) As Integer
Dim TextSize As SIZE
Dim Sprite As Any Ptr
Dim SpriteData As uByte Ptr
Dim NewSprite As uByte Ptr
Dim NewRect As RECT
Dim ReturnSpriteA As Any Ptr
Dim As Integer cx, cy
ReturnSpriteA = cPtr(Any Ptr, ReturnSprite)
'Calculate Width And Height
GetTextExtentPoint32 MemDC, StrPtr(Text), Len(Text), @TextSize
TextSize.cx += 30
If TextSize.cx + x > FB_Mode->Width Then TextSize.cx = FB_Mode->Width - x
If TextSize.cy + y > FB_Mode->Height Then TextSize.cy = FB_Mode->Height - y
Sprite = ImageCreate(TextSize.cx, TextSize.cy)
NewRect.Right = TextSize.cx
NewRect.Bottom = TextSize.cy
If ReturnSprite Then
Get ReturnSpriteA, (x, y)-(x + TextSize.cx -1, y + TextSize.cy - 1), Sprite
Else
Get (x, y)-(x + TextSize.cx -1, y + TextSize.cy - 1), Sprite
End If
'Copy To Sprite
With BitmapV4Header
.bV4Width = TextSize.cx
.bV4Height = -TextSize.cy
.bV4SizeImage = TextSize.cx * TextSize.cy * 4
End With
SetDIBits MemDC, MemBMP, 0, TextSize.cy, Sprite + 4, cPtr(BITMAPINFO Ptr, @BITMAPV4HEADER), DIB_RGB_COLORS
SetTextColor MemDC, TextColor
DrawText MemDC, StrPtr(Text), Len(Text), @NewRect, NULL
GetDIBits MemDC, MemBMP, 0, TextSize.cy, Sprite + 4, cPtr(BITMAPINFO Ptr, @BITMAPV4HEADER), DIB_RGB_COLORS
If ReturnSprite = 0 Then
'PUT On Screen
Put (x, y), Sprite, PSET
ImageDestroy Sprite
Else
Put ReturnSpriteA, (x, y), Sprite, PSET
ImageDestroy Sprite
Return TRUE
End If
End Function
Function GetTextWidth(ByVal Text As String)
Dim TextSize As SIZE
GetTextExtentPoint32 MemDC, StrPtr(Text), Len(Text), @TextSize
Return TextSize.cx
End Function
|
Viel spass beim Ausprobieren.
OlDirty
www.dekorative-holzarbeiten.de/OlDirty/Index.htm |
|
| Nach oben |
|
|
zwergnase
Anmeldungsdatum: 03.01.2006
Beiträge: 26
Wohnort: Frankfurt am Main
|
| Verfasst am: 01.08.2006, 20:46 Titel: Auch unter DOS |
|
|
| Läuft die lib auch unter DOS? |
|
| Nach oben |
|
|
Kai Bareis
Anmeldungsdatum: 10.09.2004
Beiträge: 545
Wohnort: Baden Würtemberg
|
| Verfasst am: 01.08.2006, 20:49 Titel: |
|
|
Ne unter Dos geht das nicht. Aber du kannst eventuell mit Qbasic 4.5 und der X.print Routinen von AK ARL Fonts nehmen.
_________________
MfG Kai Bareis
Es ist noch kein Meister vom Himmel gefallen! Warum einfach wens auch umständlich geht! |
|
| Nach oben |
|
|
stevie1401
Anmeldungsdatum: 04.07.2006
Beiträge: 133
|
| Verfasst am: 02.08.2006, 10:35 Titel: |
|
|
Ich habe für Windows und Linux und DOS Fonts erstellt. Ich kann sie dir gerne per E-Mail geben.
Das gute an diesen SUBS ist, dass man weder auf die die Windows-API noch auf Linux-Routinen zurückgreifen muss. Es werden die Buchstaben einfach gemalt.
Hier die SUBS, wie man die Schriften laden und damit schreiben kann. Sollte eigentlich selbsterklärend sein:
| Code: |
rem ********Programmbeginn************************************
declare sub schreibe(x,y,satz$,farbe,rechts)
declare Sub ladefont(lade$)
b=254
c=64*64
Dim Shared letter_punkte(b),letter_x(b,c),letter_y(b,c),letter_breite(b)
Screen 20,32,2,1
color 0,rgb(255,255,255)
cls
ladefont exepath+"\font\verdana08.fon"
schreibe 100,100,"Hallo Welt!",rgb(255,0,0),0
sleep
Sub ladefont(lade$)
Open "i",#1, lade$
For i=1 To 254
Input #1,letter_breite(i)
Input #1,letter_punkte(i)
For j=1 To letter_punkte(i)
Input #1,letter_x(i,j)
Input #1,letter_y(i,j)
Next j
Next i
Close #1
End Sub
Sub schreibe(x,y,satz$,farbe,rechts)
rem Erklärung für rechts:
rem Wenn rechts=0, dann schreibt er ganz normal von links nach rechts,
rem wenn rechts=1, dann schreibt er von rechts nach links.
rem Das ist sinnvoll, wenn man Zahlen untereinander schreibt.
satz_laenge=0
Dim s_pace(Len(satz$))
For i=1 To Len(satz$)
t$=Mid$(satz$,i,1)
ascii=Asc(t$)
s_pace(i)=letter_breite(ascii)
If t$=Chr$(32) Then s_pace(i)=2
satz_laenge=satz_laenge+letter_breite(ascii)
Next i
If rechts=0 Then
b=0
s=0
t=Len(satz$)
For i=1 To t
t$=Mid$(satz$,i,1)
ascii=Asc(t$)
If i=1 Then
t_space=0
Else
t_space=s_pace(i-1)+2
End If
s=s+t_space
b=b+1
If b=1 Then
For p1=1 To letter_punkte(ascii)
Pset(letter_x(ascii,p1)+x,letter_y(ascii,p1)+y),farbe
Next p1
Else
For p1=1 To letter_punkte(ascii)
Pset(letter_x(ascii,p1)+s+x,letter_y(ascii,p1)+y),farbe
Next p1
End If
Next t
End If
If rechts=1 Then
b=0
s=0
t=Len(satz$)
i=t+1
Do
i=i-1
t$=Mid$(satz$,i,1)
ascii=Asc(t$)
If b=0 Then
t_space=0
Else
t_space=s_pace(i)+2
End If
s=s+t_space
b=b+1
If b=1 Then
For p1=1 To letter_punkte(ascii)
Pset(letter_x(ascii,p1)+x,letter_y(ascii,p1)+y),farbe
Next p1
Else
For p1=1 To letter_punkte(ascii)
Pset(letter_x(ascii,p1)-s+x,letter_y(ascii,p1)+y),farbe
Next p1
End If
Loop Until i=1
End If
Erase s_pace
End Sub
rem ****Programmende*******
|
Grüsse
Stevie1401 |
|
| 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.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
