wanted: program to process Windows Font files

[paulel]

has anyone written a program that can process (and display) windows font files?
Thank you.

[bplus]

5 Years ago I did a "tour de force" of accessing Windows font files from a directory listing of Windows fonts. Still works but not a simple demo:

Code: (Select All)

'_TITLE "Ransom Note from a Madman by bplus"

'2017-09-29 modification on artmaker43's Chaotic ASCII screensaver
'2017-09-30 modified two key catching sections
'2017-10-01 test Steve's filelist code  direntry.h is in same folder as QB64.exe

'for Steve's GetFileList   this must go at top of code app that uses direntry.h
Declare CustomType Library ".\direntry"
    Function load_dir& (s As String)
    Function has_next_entry& ()
    Sub close_dir ()
    Sub get_next_entry (s As String, flags As Long, file_size As Long)
End Declare
'for Steve's GetFileList this sets up the arrays
ReDim Dir(0) As String, File(0) As String '<<<< to match already written code
'OK the main sub is loaded at bottom should be ready to make call


'DEFINT A-Z

'COMMON SHARED dirList$()
'COMMON SHARED DIRCount% 'returns file count if desired
'CONST ListMAX% = 100

'SCREEN 0
'VIEW PRINT
Color 14
Cls
Locate 5, 27
Color 9
Print "Ransom Note from a Madman";
Locate 12, 12, 1
Color 2
Print "Hit Your CASE SENSITIVE ";
Color 14
Print "<HotKey>";
Color 2
Print ", or Hit ";
Color 14
Print "<Esc>";
Color 2
Print " to Exit: ";
Color 14

'modified key catcher !!!
Do
    _Limit 25
    HotKey$ = InKey$
Loop Until Len(HotKey$)
If HotKey$ = Chr$(27) Then End
Cls: Print "One moment please..."

' and now for the madness!!!  (specially when tracking down an error)

'loadDirList "C:\Windows\Fonts\*.ttf" '<<<<<<<    old call to other sub
'calling Steve's
Dim sDir As String
Print _CWD$
sDir = "C:\Windows\Fonts\" '*.ttf"
'sDir = "C:\Users\Mark\Desktop" '\*.*" ' see if Windows not allowing access, nope not working here either
'sDir = _CWD$ + "\"
GetFileList sDir, Dir(), File()
' what is wrong ??? Fixed the sDir needs a slash at the end !!!!
'PRINT "Files of " + sDir
For i = LBound(File) To 10
    Print i, File(i)
Next
'PRINT "Do you see any?"
'END

'then there is problem ubound = lbound one file or none?
DIRCount% = UBound(File) - LBound(File)
'PRINT DIRCount%
'PRINT UBOUND(File) 'ok they match
'END
If DIRCount% > 100 Then
    DIRCount% = 100
    Dim h&(1000, 1)
    For i = 1 To DIRCount%
        'PRINT dirList$(i)
        For sz = 0 To 9
            h&((i - 1) * 10 + sz, 0) = _LoadFont(File(i), (sz + 1) * 10)
            progress = (i - 1) * 10 + sz
            If progress Mod 100 = 0 Then Print (1000 - progress) \ 100; "..."
            'save name and size of screw up
            'IF (i - 1) * 10 + sz = 42 THEN saveF$ = dirList$(i): saveS = (sz + 1) * 10
        Next
        '_DELAY .2  'checking loading
    Next
    'SLEEP
    'screw one up just to make sure the error catching is working
    'h&(42, 0) = _LOADFONT("x.ttf", 0)
Else
    Print "Sorry, No " + sDir + " files found."
    Sleep
    End
End If

xmax = _DesktopWidth - 100
ymax = _DesktopHeight - 100
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 50, 50
Randomize Timer
errCnt = 0
While 1

    character = Int((255) * Rnd + 1)
    While character = 32
        character = Int((255) * Rnd + 1)
    Wend
    r = 64 * (Int(Rnd * 5)): g = 64 * (Int(Rnd * 5)): b = 64 * (Int(Rnd * 5))
    r = Int(Rnd * 2) * r: g = Int(Rnd * 2) * g: b = Int(Rnd * 2) * b
    Color _RGBA(255 - r, 255 - g, 255 - b, Rnd * 200), _RGB(r, g, b)
    rh = Int(Rnd * 1000)
    On Error GoTo errhandler
    If h&(rh, 1) = 0 Then _Font h&(rh, 0)
    _PrintString (xmax * Rnd, ymax * Rnd), Chr$(character)

    'modified key catcher !!!!
    _Limit 1500
    If InKey$ = HotKey$ Then Exit While
Wend

'tracking down trouble fonts and or font sizes
Color _RGB(255, 255, 255), 0
h1& = _LoadFont("C:\Windows\Fonts\Arial.ttf", 16)
_Font h1&
ti = 0
For i = 0 To 1000
    If h&(i, 1) Then
        ti = ti + 1
        ReDim _Preserve trouble$(ti)
        trouble$(ti) = File(1 + i \ 10) + Str$(10 * (1 + (i Mod 10))) 'OK fixed
    End If
Next
Cls
If ti Then display trouble$()
If errCnt Then Print "Error Count: "; errCnt: Sleep
'PRINT "Font screw up = "; saveF$
'PRINT "Size screw up = "; saveS
End

'track troubling font and size
errhandler:
errCnt = errCnt + 1
h&(rh, 1) = 1
Resume Next

'' modified function from Help files
'SUB loadDirList (spec$)
'    CONST TmpFile$ = "DIR$INF0.INF"
'    STATIC Ready%, Index%
'    IF NOT Ready% THEN REDIM dirList$(ListMAX%): Ready% = -1 'DIM array first use
'    IF spec$ > "" THEN 'get file names when a spec is given
'        SHELL _HIDE "DIR " + spec$ + " /b > " + TmpFile$
'        Index% = 0: dirList$(Index%) = "": ff% = FREEFILE
'        OPEN TmpFile$ FOR APPEND AS #ff%
'        size& = LOF(ff%)
'        CLOSE #ff%
'        IF size& = 0 THEN KILL TmpFile$: EXIT SUB
'        OPEN TmpFile$ FOR INPUT AS #ff%
'        DO WHILE NOT EOF(ff%) AND Index% < ListMAX%
'            Index% = Index% + 1
'            LINE INPUT #ff%, dirList$(Index%)
'        LOOP
'        DIRCount% = Index% 'SHARED variable can return the file count
'        CLOSE #ff%
'        KILL TmpFile$
'    ELSE IF Index% > 0 THEN Index% = Index% - 1 'no spec sends next file name
'    END IF
'END SUB

Sub display (arr() As String)
    lb = LBound(arr): ub = UBound(arr)
    If ub - lb + 1 < 21 Then top = ub Else top = lb + 19
    Cls: Print "press any key to quit scroller..."
    Locate 2, 1
    For i = lb To top
        Print arr(i)
    Next
    Do
        If ub - lb + 1 > 20 Then
            Do While _MouseInput
                If row >= lb Then row = row + _MouseWheel Else row = lb 'prevent under scrolling
                If row > ub - 19 Then row = ub - 19 'prevent over scrolling
                If prevrow <> row Then 'look for a change in row value
                    If row >= lb And row <= ub - 19 Then
                        Cls: Print "press any key to quit scroller..."
                        Locate 2, 1
                        For n = row To row + 19
                            Print arr(n)
                        Next
                    End If
                End If
                prevrow = row 'store previous row value
            Loop
        End If
    Loop Until InKey$ > ""
End Sub

'Steve's main sub working with the direntry.h file for file lists
Sub GetFileList (SearchDirectory As String, DirList() As String, FileList() As String)
    Const IS_DIR = 1
    Const IS_FILE = 2
    Dim flags As Long, file_size As Long

    ReDim _Preserve DirList(100), FileList(100)
    DirCount = 0: FileCount = 0

    If load_dir(SearchDirectory) Then
        Do
            length = has_next_entry
            If length > -1 Then
                nam$ = Space$(length)
                get_next_entry nam$, flags, file_size
                If flags And IS_DIR Then
                    DirCount = DirCount + 1
                    If DirCount > UBound(DirList) Then ReDim _Preserve DirList(UBound(DirList) + 100)
                    DirList(DirCount) = nam$
                ElseIf flags And IS_FILE Then
                    FileCount = FileCount + 1
                    If FileCount > UBound(FileList) Then ReDim _Preserve FileList(UBound(FileList) + 100)
                    FileList(FileCount) = nam$
                End If
            End If
        Loop Until length = -1
        close_dir
    Else
    End If
    ReDim _Preserve DirList(DirCount)
    ReDim _Preserve FileList(FileCount)
End Sub

It might be a mod of someone else eg the hot key crap, just press spacebar as alternate quit key along with escape. It also makes a list in Console of files not accessable.    Oh that's not Console that's my own scroller Sub displaying list of fonts not working (This is oldie.)

Put this file, direntry.h, in same folder as your QB64 exe file:

  direntry.h (Size: 1.21 KB / Downloads: 69)

Also the GetFileList sub may have been updated even a couple of times but this one works for me fine, today anyway ;-))

[bplus]

has anyone written a program that can process (and display) windows font files?
Thank you.

BTW there is nothing to process, use FontHandle& = _loadFont( ) with specs, see wiki and then set font to use with _Font FontHandle&
https://qb64phoenix.com/qb64wiki/index.php/LOADFONT

[Pete]

@bplus

Mark,

Didn't you also make a custom font program? I'm curious because I posted how to use two font sizes in one program by making a hardware overlay. For SCREEN 0, that's essential, but with a graphics program custom fonts could be created in a variety of sizes and applied to the same screen.

Pete

[bplus]

I made code for drawing scalable letters (and digits?).

With RotoZoom or even _PutImage you can scale and Rotate any font letters individually or whole text lines or blocks.

[SpriggsySpriggs]

I made something a long time ago on the old forum that would display the font dialog in Windows and after you pick the options it would display some text using the selected options. Worked rather well. Don't know where it is now

[Pete]

Where's Richard? QWERTY. He started keeping all this stuff organized at .rip. "Librarian" dude.

Pete

[paulel]

bplus,

been programming for all these years only now learned of the _FONT function.
thank you.

[bplus]

bplus,

been programming for all these years only now learned of the _FONT function.
thank you.

Yeah there are still things I am learning QB64 has!

[Pete]

Steve wanted to introduce the $Pete meta-command. $Pete automatically swaps every indexed QB64 statement to the next indexed statement. That way Steve says when your program runs, you can expect to get the same output every program Pete ever coded would produce.

Pete

- A Proud Graduate of Foo-U.