TTF Converter for DRAW STRING

User projects written in or related to FreeBASIC.
jsherk
Posts: 82
Joined: Jun 09, 2006 22:40
Contact:

Postby jsherk » Dec 11, 2008 15:01

So should I wait for an official release of v0.21.0 before I continue trying to do what I'm doing? Or are you saying that the font width data is supposed to be stored in bmp, but v0.20.0 can't retrieve it?

Thanks
Zippy
Posts: 1295
Joined: Feb 10, 2006 18:05

Postby Zippy » Dec 11, 2008 16:13

@jsherk

[After testing and research] jofers' code with our mods creates bitmaps that work with bload() and Draw String(), except in freeBASIC version 0.20 where a mod to bload() made it.. stop working. This bload() mod HAS been reverted in source code.

You can download and install an interim version that contains the "reversion", 0.21 (12-01-2008 is the latest), from the link in my previous post. The downloads are zip files, they can be extracted directly "over" your existing fb 0.20 install, make a backup first.

It helps the devs if we test these interim versions, otherwise issues like the bload() mod can creep into official releases.

-----

There's another tiny issue with the TTF converter code. It doesn't handle descenders well, the tails of lowercase characters (Z"jpg.."Z) that extend below the base line are cutoff. There's a simpleworkaround:

Code: Select all

'in SaveFile()
'add this line:
BitmapHeight += 1 'new

'immediately before this existing line:
BitmapSize = BitmapHeight * BitmapWidth * 4


I'm trying to mod the code to allow diferent character ranges, i.e., "48 to 58", with incomplete success. It should be simple..
Zippy
Posts: 1295
Joined: Feb 10, 2006 18:05

Postby Zippy » Dec 12, 2008 1:28

I've modded jofer's code to allow character range selections for the output font. I'm not happy, I had to mod the dialog box and - I'm not happy. If I wanted to design Windows windows (a dialog, in this case) I'd be using VB. Kudos to FBEdit.

I'm going to post the complete fixed/modded code, and .rc, and a test.bas. If jofers objects then someone can whack it later.

Code: Select all

'"TTF to GfxLib Font Converter.bas"
' slightly modded @jofer's code
' use fb versions 0.17, 0.18, or >=0.21
'
' saveas:     TTFtoGfxLib.bas
' save .rc as TTFtoGfxLib.rc
' compile -s gui TTFtoGfxLib.bas TTFtoGfxLib.rc
'
#include "windows.bi"
#include "win/commdlg.bi"
#include "crt.bi"
'
#define DLG_MAIN 1000
#define BTN_SAVE 1001
#define BTN_FONT 1002
#define BTN_BKGR 1003
#define CHK_TRAN 1004
#define LBL_MAIN 1005
'Zbegin change - see .rc
#define IDC_EDT1 1006
#define IDC_EDT2 1007
'Zend  change
#define ICO_MAIN 1010
'
Type Global
    BackgroundColor  As COLORREF
    BitmapInfo       As BITMAPINFO
    ChooseColor      As CHOOSECOLOR
    CustColors(15)   As COLORREF
    ChooseFont       As CHOOSEFONT
    hBrush           As HBRUSH
    hBrushPrev       As HBRUSH
    hFont            As HFONT
    hFontPrev        As HFONT
    IsTransparent    As Integer
    LogFont          As LOGFONT
    OpenFileName     As OPENFILENAME
    SaveName         As String*255
    SaveFilter       As String*255
End Type

Declare Function DlgProc (ByVal hWnd As HWND, ByVal uMsg As UINT, BYVal wParam As WPARAM, ByVal lParam As LPARAM) As BOOL
Declare Sub EditColor(ByVal hWnd As HWND)
Declare Sub EditFont(ByVal hWnd As HWND)
Declare Sub SaveFile(ByVal hWnd As HWND)
Declare Sub SaveBitmap(ByVal hWnd As HWND, ByVal hDC As HDC, ByVal hBitmap As HBITMAP, ByVal File As String)

Dim Shared Global As Global
dim shared as integer lowChar,highChar

DialogBox(GetModuleHandle(NULL), MAKEINTRESOURCE(DLG_MAIN), NULL, @DlgProc)
End

Function DlgProc (ByVal hWnd As HWND, ByVal uMsg As UINT, BYVal wParam As WPARAM, ByVal lParam As LPARAM) As BOOL
    Dim ID As Integer
    Dim Event As Integer
    Dim hDC As HDC
    Dim hBrush As HBRUSH
    Dim x As Integer
    Dim SaveFilterArray As UByte Ptr
    Dim hWndControl As HWND

'Zb
    dim as integer res
    dim as string lowstr,highstr,errstr
'Ze

    Select Case uMsg
        Case WM_INITDIALOG
            With Global
                ' Set up all structure information
                .SaveFilter = "Bitmap Files (*.bmp)%*.BMP%All Files (*.*)%*.*%%"
                SaveFilterArray = StrPtr(.SaveFilter)
                For x = 0 To Len(.SaveFilter)
                    If SaveFilterArray[x] = Asc("%") Then SaveFilterArray[x] = 0
                Next x

                .BackgroundColor = GetSysColor(COLOR_WINDOW)
                .hBrush = GetSysColorBrush(COLOR_WINDOW)
                .IsTransparent = TRUE
                memset(@Global.CustColors(0), 255, SizeOf(COLORREF)*16)
                With .ChooseColor
                    .lStructSize = SizeOf(CHOOSECOLOR)
                    .hWndOwner = hWnd
                    .rgbResult = Global.BackgroundColor
                    .lpCustColors = @Global.CustColors(0)
                    .flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_SOLIDCOLOR
                End With

                With .ChooseFont
                    .lStructSize = SizeOf(CHOOSEFONT)
                    .hInstance = GetModuleHandle(NULL)
                    .hWndOwner = hWnd
                    .lpLogFont = @Global.LogFont
                    .Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
                End With

                With .OpenFileName
                    .lStructSize = SizeOf(OPENFILENAME)
                    .hInstance = GetModuleHandle(NULL)
                    .hWndOwner = hWnd
                    .lpstrFilter = StrPtr(Global.SaveFilter)
                    .lpstrFile = StrPtr(Global.SaveName)
                    .nMaxFile = 255
                End WIth

                With .LogFont
                    .lfFaceName = "MS Sans Serif"
                    .lfHeight = -MulDiv(8, GetDeviceCaps(GetDC(NULL), LOGPIXELSY), 72)
                End With

                Global.hFont = CreateFontIndirect(Global.ChooseFont.lpLogFont)
            End With

            CheckDlgButton(hWnd, CHK_TRAN, BST_CHECKED)
            Global.IsTransparent = TRUE

        Case WM_CLOSE
            EndDialog(hWnd, 0)

        Case WM_CTLCOLORSTATIC
            If GetDlgCtrlID(Cast(hWND, lParam)) = LBL_MAIN Then
                hDC = Cast(HDC, wParam)
                SetTextColor(hDC, Global.ChooseFont.rgbColors)

                If Global.IsTransParent = TRUE Then
'Zb
'  fix transparent background
'
                    'SetBkColor(hDC, RGB(255, 255, 255))
                    SetBkColor(hDC, RGBA(255, 0, 255, 0))
'Ze
                    Return Cast(LRESULT, GetSysColorBrush(COLOR_WINDOW))
                Else
                    SetBkColor(hDC, Global.BackgroundColor)
                    Return Cast(LRESULT, Global.hBrush)
                End If
            End If
        Case WM_COMMAND
            ID = LoWord(wParam)
            Event = HiWord(wParam)

            Select Case ID
                Case BTN_SAVE
                    '
                    lowstr=space(16):highstr=space(16)
                    res=GetDlgItemText(hwnd,IDC_EDT1,(lowstr),16)
                    res=GetDlgItemText(hwnd,IDC_EDT2,(highstr),16)
                    '
                    lowChar =val(trim(lowstr))
                    highChar=val(trim(highstr))
                    '
                    errstr=""
                    if lowChar <0 or lowChar>255 then
                        errstr="MinChar <0 or >255"
                    end if
                    if errstr<>"" then
                        messagebox(hwnd,errstr,"Error",MB_ICONSTOP)
                        return false
                    end if
                    if lowChar>highChar then
                        errstr="MinChar > MaxChar"
                    end if
                    if errstr<>"" then
                        messagebox(hwnd,errstr,"Error",MB_ICONSTOP)
                        return false
                    end if
                    '
                    if highChar <0 or highChar>255 then
                        errstr="MaxChar <0 or >255"
                    end if
                    if errstr<>"" then
                        messagebox(hwnd,errstr,"Error",MB_ICONSTOP)
                        return false
                    end if
                    '
                    SaveFile(hWnd)
                Case BTN_FONT
                    EditFont(hWnd)
                Case BTN_BKGR
                    EditColor(hWnd)
                Case CHK_TRAN
                    hWndControl = GetDlgItem(hWnd, BTN_BKGR)

                    If IsDlgButtonChecked(hWnd, CHK_TRAN) = BST_CHECKED Then
                        Global.IsTransparent = TRUE
                        Global.LogFont.lfQuality = NONANTIALIASED_QUALITY

                        ' Enable the 'background color' button
                        EnableWindow(hWndControl, FALSE)
                    Else
                        Global.IsTransParent = FALSE
                        Global.LogFont.lfQuality = ANTIALIASED_QUALITY

                        ' Disable the 'background color' button
                        EnableWindow(hWndControl, TRUE)
                    End If

                    Global.hFontPrev = Global.hFont
                    Global.hFont = CreateFontIndirect(@Global.LogFont)
                    SendDlgItemMessage(hWnd, LBL_MAIN, WM_SETFONT, Cast(WPARAM, Global.hFont), TRUE)
                    DeleteObject(Global.hFontPrev)
            End Select

        Case Else
            Return FALSE
    End Select

    Return TRUE
End Function

Sub EditFont(ByVal hWnd As HWND)
    ' If a font is chosen, set all the variables
    If ChooseFont(@Global.ChooseFont) = TRUE Then
        Global.hFontPrev = Global.hFont
        If Global.IsTransparent = TRUE Then
            Global.LogFont.lfQuality = NONANTIALIASED_QUALITY
        Else
            Global.LogFont.lfQuality = ANTIALIASED_QUALITY
        End If

        Global.hFont = CreateFontIndirect(Global.ChooseFont.lpLogFont)
        SendDlgItemMessage(hWnd, LBL_MAIN, WM_SETFONT, Cast(WPARAM, Global.hFont), TRUE)
        DeleteObject(Global.hFontPrev)
    End If
End Sub

Sub EditColor(ByVal hWnd As HWND)
    Dim hWndControl As HWND

    If ChooseColor(@Global.ChooseColor) = TRUE Then
        Global.BackgroundColor = Global.ChooseColor.rgbResult
        Global.hBrushPrev = Global.hBrush
        Global.hBrush = CreateSolidBrush(Global.BackgroundColor)
        DeleteObject(Global.hBrushPrev)

        hWndControl = GetDlgItem(hWnd, LBL_MAIN)
        InvalidateRect(hWndControl,NULL,TRUE)
        UpdateWindow(hWndControl)
    End If
End Sub

Sub SaveFile(ByVal hWnd As HWND)
    Dim MemDC As HDC
    Dim MemBMP As HBITMAP
    Dim BitmapWidth As Integer
    Dim BitmapHeight As Integer
    Dim BitmapSize As Integer
    Dim BitmapInfo As BITMAPINFO
    Dim FileName As String
    Dim i As Integer
    Dim x As Integer
    Dim y As Integer
    Dim WidthArray(lowChar To highChar) As Integer
    Dim ABCArray(lowChar To highChar) As ABC
    Dim ThisWidth As SIZE
    Dim TextMetric As TEXTMETRIC
    Dim IsTrueType As Integer

    Dim Buffer As UByte Ptr

    ' If a save name is chosen...
    If GetSaveFileName(@Global.OpenFileName) Then

        ' Create a memory DC and select our font into it
        MemDC = CreateCompatibleDC(NULL)
        If (MemDC = 0) Or (Global.hFont = 0) Then
            MessageBox(hWnd, "Could not create Bitmap", "Error", MB_ICONERROR)
            Exit Sub
        End If
        SelectObject(MemDC, Global.hFont)

        ' Get character widths
        IsTrueType = GetCharABCWidths(MemDC, lowChar, highChar, @ABCArray(lowChar))

        For i = lowChar To highChar
            GetTextExtentPoint32(MemDC, Chr(i), 1, @ThisWidth)
            If IsTrueType Then
                WidthArray(i) = ABCArray(i).abcB
                If ABCArray(i).abcC > 0 Then WidthArray(i) += ABCArray(i).abcC
                If ABCArray(i).abcA > 0 Then WidthArray(i) += ABCArray(i).abcA
            Else
                WidthArray(i) = ThisWidth.cx
            End If
            BitmapWidth += WidthArray(i)
            If ThisWidth.cy > BitmapHeight Then BitmapHeight = ThisWidth.cy
        next i

'Zb
'  handle descenders, "gjp" etc.
'
        if highChar>=97 then
            BitmapHeight += 1
        end if
'Ze
        BitmapSize = BitmapHeight * BitmapWidth * 4

        ' Create DIB section & select it into memory DC
        With Global.BitmapInfo.bmiHeader
            .biSize = SizeOf(BITMAPINFOHEADER)
            .biWidth = BitmapWidth
            .biHeight = BitmapHeight
            .biPlanes = 1
            .biBitCount = 32
            .biCompression = BI_RGB
        End With

        MemBMP = CreateDIBSection(MemDC, @Global.BitmapInfo, DIB_RGB_COLORS, @Buffer, NULL, 0)
        SelectObject MemDC, MemBMP
        If Global.IsTransparent = True Then
'Zb
'  fix transparent background
'
            'SetBkColor(MemDC, RGB(255, 255, 255))
            SetBkColor(MemDC, RGBA(255, 0, 255, 0))
'Ze
        Else
            SetBkColor(MemDC, Global.BackgroundColor)
        End If
        SetTextColor(MemDC, Global.ChooseFont.rgbColors)

        If MemBMP = 0 Or Buffer = 0 Then
            MessageBox(hWnd, "Could not create Bitmap", "Error", MB_ICONERROR)
            DeleteObject(MemDC)
            Exit Sub
        End If

        'Fill in font info and draw letters
        Buffer[BitmapSize-BitmapWidth*4] = 0
        Buffer[BitmapSize-BitmapWidth*4+1] = lowChar
        Buffer[BitmapSize-BitmapWidth*4+2] = highChar

        x = 0
        For i = lowChar To highChar
            If ABCArray(i).abcA < 0 Then x -= ABCArray(i).abcA
            TextOut(MemDC, x, 1, Chr(i), 1)
'Zb
'  accomodate different character ranges
'
'            Buffer[BitmapSize-BitmapWidth*4 + i - 29] = WidthArray(i)
            Buffer[BitmapSize-BitmapWidth*4 + i - lowChar + 3] = WidthArray(i)
'Ze
            If ABCArray(i).abcA < 0 Then x += ABCArray(i).abcA
            x += WidthArray(i)
        Next i

        FileName = *Global.OpenFileName.lpstrFile
        If UCase(Right(FileName, 4)) <> ".BMP" Then FileName += ".bmp"

        SaveBitmap(hWnd, MemDC, MemBMP, FileName)

        MessageBox hWnd, "Complete!", "Hurray!", MB_OK
    End If
End Sub

Sub SaveBitmap(ByVal hWnd As HWND, ByVal hDC As HDC, ByVal hBitmap As HBITMAP, ByVal File As String)
    Dim fp As FILE Ptr
    Dim Bitmap As BITMAP
    Dim BitmapInfo As BITMAPINFO
    Dim BitmapFileHeader As BITMAPFILEHEADER
    Dim Buffer As UByte Ptr
    fp = fopen(File, "wb")
    If fp = 0 Then
        MessageBox hWnd, "Error Saving Bitmap", "Error", MB_ICONERROR
        Exit Sub
    End If

    BitmapInfo.bmiHeader.biSize = SizeOf(BITMAPINFOHEADER)
    BitmapInfo.bmiHeader.biBitCount = 0

    If GetDIBits(hDC, hBitmap, 0, 0, NULL, @BitmapInfo, DIB_RGB_COLORS) = 0 Then
        MessageBox hWnd, "GetDIBits Error Saving Bitmap", "Error", MB_ICONERROR
        fclose(fp)
        Exit Sub
    End If

    Bitmap.bmHeight = BitmapInfo.bmiHeader.biHeight
    Bitmap.bmWidth = BitmapInfo.bmiHeader.biWidth

    With BitmapFileHeader
        .bfType = &h4d42
        .bfSize = (((3 * Bitmap.bmWidth + 3) And Not 3) * Bitmap.bmHeight)
        .bfSize += SizeOf(BITMAPFILEHEADER)
        .bfSize += SizeOf(BITMAPINFOHEADER)
        .bfOffBits = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER)
    End With

    BitmapInfo.bmiHeader.biCompression = 0
    fwrite(@BitmapFileHeader, SizeOf(BITMAPFILEHEADER),1,fp)
    fwrite(@BitmapInfo.bmiHeader, SizeOf(BITMAPINFOHEADER),1,fp)

    Buffer = Allocate(BitmapInfo.bmiHeader.biSizeImage + 5)
    If GetDIBits(hDC, hBitmap, 0, Bitmap.bmHeight, Buffer, @BitmapInfo, DIB_RGB_COLORS) = 0 Then
        Deallocate Buffer
        MessageBox hWnd, "Error Saving Bitmap", "Error", MB_ICONERROR
        fclose(fp)
        Exit Sub
    End If

    fwrite(Buffer,1,BitmapInfo.bmiHeader.biSizeImage,fp)
    fclose(fp)
End Sub


I'm going to QUOTE the .rc so the CaSe is preserved, save this as:
TTFtoGfxLib.rc
#include "windows.h"

1000 DIALOGEX 106,107,194,78
CAPTION "TTF - GfxLib Font Converter"
FONT 8,"MS Sans Serif",0,0,0
STYLE 0x10CA0000
EXSTYLE 0x00000300
BEGIN
CONTROL "Save",1001,"Button",0x50010000,130,24,60,15
CONTROL "Select Font",1002,"Button",0x50010000,129,5,60,14
CONTROL "Background Color",1003,"Button",0x58010000,109,43,80,14
CONTROL "Transparent Background",1004,"Button",0x50030003,5,43,100,14
CONTROL "AaBbCDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz",1005,"Static",0x50020000,5,5,121,34,0x00020200
CONTROL "32",1006,"Edit",0x50010000,62,62,18,13,0x00000200
CONTROL "128",1007,"Edit",0x50010000,146,62,18,13,0x00000200
CONTROL "MinChar",1008,"Static",0x50000201,22,62,36,11
CONTROL "MaxChar",1009,"Static",0x50000201,104,62,36,11
END



And then a test..

Code: Select all

'saved bitmap font test
' Your saved font must be visible - if you let the default
'  then you'll have black text, perhaps on a black background.
'
dim as integer   c,fontWidth,fontHeight,res
dim as integer   MinChar,MaxChar
dim as ubyte ptr fontBuffer
dim as string    ts
'
'please change this to the name of your saved font
dim as string    fontFile = "t.bmp" 'the font bitmap
'
'need gfx and >=24 bit
screenres 640,480,32
'
'get the font bitmap sizes
open fontFile for binary access read as #1
get #1,19,fontWidth
get #1,,fontHeight
close #1
'
'create the image buffer, load font
fontBuffer=imagecreate(fontWidth,fontHeight)
res=bload(fontFile,fontBuffer)
if res<>0 then
    print "There was a prob loading ";fontFile
    print "  fix and start."
    sleep
    end
end if
'
'just test print of vals
for c=32 to 42
print c,fontbuffer[c]
next
'
'here we get the min and max chars from the loaded bmp
'  some error checking might be called for..
ts=""
MinChar=fontbuffer[33]
MaxChar=fontbuffer[34]
for c=MinChar to MaxChar
    ts+=chr(c)
next
'
'our font test..
draw string(10,100),ts,,fontBuffer
'
sleep
end

I'll add some "conclusions" later.
jofers
Posts: 1525
Joined: May 27, 2005 17:18
Contact:

Postby jofers » Jan 12, 2009 23:39

Thanks Zippy, I've updated the download:
http://betterwebber.com/stuff/ttf_to_gfxlib_v20.zip

I didn't test it though, so if there are errors let me know.
badmrbox
Posts: 659
Joined: Oct 27, 2005 14:40
Location: Sweden
Contact:

Postby badmrbox » Jan 13, 2009 15:02

I seem to get 3 empty files when I download your latest zip.
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Jan 22, 2009 0:57

Question: How to get length of each char in custom font, since each glypth has its own width?
Sisophon2001
Posts: 1704
Joined: May 27, 2005 6:34
Location: Cambodia, Thailand, Lao, Ireland etc.
Contact:

Postby Sisophon2001 » Jan 22, 2009 12:27

duke4e wrote:Question: How to get length of each char in custom font, since each glypth has its own width?


Some code here

http://www.freebasic.net/forum/viewtopic.php?p=114517#114517

And look also at BasicScience code lower down, if you are using the same library as he is.

Garvan
jofers
Posts: 1525
Joined: May 27, 2005 17:18
Contact:

Postby jofers » Jan 31, 2009 20:28

Heh, whoops, link fixed :)
nobozoz
Posts: 238
Joined: Nov 17, 2005 6:24
Location: Chino Hills, CA, USA

Postby nobozoz » Feb 03, 2009 3:29

Weird problem ----
I downloaded the zip file from the above link and extracted the files - OK.

Loaded "gfx_ttf_v20_ex.bas" into fbedit v1.0.6.6 - OK.

Compile and run program once - OK.

Add a simple, print statement (print "here1-") to gfx_ttf_v20_ex.bas and save.

FBedit displays source - OK.

Try to compile and run - !!! source errors !!! can't compile. Fbedit shows everything is fine onscreen (I guess because the entire text is being edited and held in RAM). But the saved gfx_ttf_v20_ex.bas file on DISK now has all newlines stripped out of it. I opened the new saved version of gfx_ttf_v20_ex.bas from DISK with another text editor and ALL the newlines are GONE! (or at least, something is bizarre with the loss of formatting).

I tried some other .bas files that are from the fbc\examples folder, and they all seem to open, edit, save and re-open correctly in fbedit.

I copy-pasted "gfx_ttf_v20_ex.bas" from the fbforum to fbedit compiled-OK ran-OK edited_OK saved-OK re-opened-OK.

Another weird thing is I can't move th cursor into a commented line - only to the leftmost position.

Are you using some weird code page? Linux? Is your zipped corrupt?

Jim
counting_pine
Site Admin
Posts: 6220
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Postby counting_pine » Feb 03, 2009 7:29

It's an FbEdit problem: It seems to completely remove Linux-style line endings from files when it saves.
It only happens with this code because it's saved using Linux-style "LF" line endings, rather than Windows-style "CR,LF" line endings.

A simple workaround is to open and save the files using Wordpad, which converts all the line-endings. But this is something that should really be reported to the FbEdit developer(s).
vdecampo
Posts: 2982
Joined: Aug 07, 2007 23:20
Location: Maryland, USA
Contact:

Postby vdecampo » Feb 16, 2009 16:46

I donwloaded this and compiled and I got the error ....

Error!
No resources found in RC file
OBJ file not made


:(

-Vince
CommanderRaven
Posts: 86
Joined: Jan 22, 2009 18:52
Location: Houston, tx

Postby CommanderRaven » Mar 03, 2009 15:59

You are getting the error due to file format difference between Linux/unix and Windows.

Open up each file in Wordpad. And save them.

Then you can compile.



vdecampo wrote:I donwloaded this and compiled and I got the error ....

Error!
No resources found in RC file
OBJ file not made


:(

-Vince

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 4 guests