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:
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 ;-))
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 SubIt 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 ;-))
b = b + ...