wanted: program to process Windows Font files

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