home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l391 / 2.ddi / FONT.BA$ / FONT.bin
Encoding:
Text File  |  1992-08-19  |  52.1 KB  |  1,822 lines
  1. ' ------------------------------------------------------------------------
  2. ' Visual Basic for MS-DOS Presentation Graphics ToolKit
  3. '
  4. ' The Presentation Graphics ToolKit (CHART.BAS, CHARTASM.ASM,
  5. ' FONT.BAS, and FONTASM.ASM) provides support for adding
  6. ' charts, graphs, and fonts to your programs.
  7. '
  8. ' To use the Presentation Graphics routines in your
  9. ' program either include CHART.BAS and FONT.BAS in
  10. ' your program or use the supplied library (CHART.LIB, CHARTA.LIB)
  11. ' and Quick Library (CHART.QLB) and call the appropriate
  12. ' procedures.
  13. '
  14. ' The font support routines can be used without the
  15. ' charting routines.  To use the font routines
  16. ' in your program either inlcude FONT.BAS in your
  17. ' program or use the supplied library (FONT.LIB, FONTA.LIB)
  18. ' and Quick Library (FONT.QLB) and call the appropriate
  19. ' procedures.
  20. '
  21. ' The following font files are provided with the Font
  22. ' ToolKit:
  23. '   Raster fonts designed for screen resolution of 640x350
  24. '       COURB.FON
  25. '       HELVB.FON
  26. '       TMSRB.FON
  27. '   Raster fonts designed for screen resolution of 640x480
  28. '       COURE.FON
  29. '       HELVE.FON
  30. '       TMSRE.FON
  31. '
  32. ' Note, if you include CHART.BAS and FONT.BAS in your
  33. ' program, you will also have to create and use a
  34. ' library and Quick Library containing the low-level
  35. ' support routines found in CHARTASM.ASM and FONTASM.ASM.
  36. ' This is done as follows:
  37. '       LIB chartasm.lib + chartasm + fontasm + VBDOS.LIB;
  38. '       LINK /Q chartasm.lib, chartasm.qlb,, VBDOSQLB.LIB;
  39. ' If you include just FONT.BAS in your program, you
  40. ' will also have to create and use a library and
  41. ' Quick Library containing the low-level support
  42. ' routines found in FONTASM.ASM. This is done as follows:
  43. '       LIB fontasm.lib + fontasm + VBDOS.LIB;
  44. '       LINK /Q fontasm.lib, fontasm.qlb,,VBDOSQLB.LIB;
  45. '
  46. ' Copyright (C) 1982-1992 Microsoft Corporation
  47. '
  48. ' You have a royalty-free right to use, modify, reproduce
  49. ' and distribute the sample applications and toolkits provided with
  50. ' Visual Basic for MS-DOS (and/or any modified version)
  51. ' in any way you find useful, provided that you agree that
  52. ' Microsoft has no warranty, obligations or liability for
  53. ' any of the sample applications or toolkits.
  54. ' ------------------------------------------------------------------------
  55.  
  56. ' FONT.BI contains all of the TYPE definitions and SUB declarations
  57. ' required for graphics text:
  58. ' $INCLUDE: 'FONT.BI'
  59.  
  60. ' VBDOS.BI contains TYPE definitions and procedure declarations
  61. ' for the routines in VBDOS.LIB that are used by the
  62. ' font routines.
  63. ' $INCLUDE: 'VBDOS.BI'
  64.  
  65.  
  66. CONST cFALSE = 0              ' Logical False
  67. CONST cTRUE = NOT cFALSE      ' Logical True
  68.  
  69. CONST cDefaultColor = 15      ' Default character color (white in all modes)
  70. CONST cDefaultDir = 0         ' Default character direction
  71. CONST cDefaultFont = 1        ' Default font selected in LoadFont
  72.  
  73. CONST cMaxFaceName = 32       ' Maximum length of a font name
  74. CONST cMaxFileName = 66       ' Maximum length of a font file name
  75. CONST cFontResource = &H8008  ' Identifies a font resource
  76. CONST cBitMapType = 0         ' Bitmap font type
  77.  
  78. CONST cFileFont = 0           ' Font comes from file
  79. CONST cMemFont = 1            ' Font comes from memory
  80.  
  81. CONST cSizeFontHeader = 118   ' Size of Windows font header
  82.  
  83. ' Below are TYPE definitions local to this module:
  84.  
  85. ' Some global variables used:
  86. TYPE GlobalParams
  87.     MaxRegistered     AS INTEGER     ' Max number of registered fonts allowed
  88.     MaxLoaded         AS INTEGER     ' Max number of loaded fonts allowed
  89.     TotalRegistered   AS INTEGER     ' Number of fonts actually registered
  90.     TotalLoaded       AS INTEGER     ' Number of fonts actually loaded
  91.  
  92.     NextDataBlock     AS INTEGER     ' Next available block in font buffer
  93.  
  94.     CurrentFont       AS INTEGER     ' Current font number in loaded fonts
  95.     CHeight           AS INTEGER     ' Character height of current font
  96.     FChar             AS INTEGER     ' First char in font
  97.     LChar             AS INTEGER     ' Last char in font
  98.     DChar             AS INTEGER     ' Default char for font
  99.     DSeg              AS INTEGER     ' Segment of current font
  100.     DOffset           AS INTEGER     ' Offset of current font
  101.     FontSource        AS INTEGER     ' Source of current font (File or Mem)
  102.  
  103.     CharColorInit     AS INTEGER     ' cFALSE (0) means color not initialized
  104.     CharColor         AS INTEGER     ' Character color
  105.     CharDirInit       AS INTEGER     ' cFALSE (0) means dir not initialized
  106.     CharDir           AS INTEGER     ' Character direction
  107.     CharSet           AS INTEGER     ' Character mappings to use
  108.  
  109.     XPixInc           AS INTEGER     ' X increment direction (0, 1, -1)
  110.     YPixInc           AS INTEGER     ' Y increment direction (0, 1, -1)
  111.  
  112.     WindowSet         AS INTEGER     ' cTRUE if GTextWindow has been called
  113.     WX1               AS SINGLE      ' Minimum WINDOW X
  114.     WY1               AS SINGLE      ' Minimum WINDOW Y
  115.     WX2               AS SINGLE      ' Maximum WINDOW X
  116.     WY2               AS SINGLE      ' Maximum WINDOW Y
  117.     WScrn             AS INTEGER     ' cTRUE means Y increases top to bottom
  118.  
  119. END TYPE
  120.  
  121. ' The following 3 types are needed to read .FON files. They are documented
  122. ' in chapter 7 of the MS Windows Programmer's Reference:
  123.  
  124. ' Windows font file header:
  125. TYPE WFHeader
  126.     dfVersion         AS INTEGER
  127.     dfSize            AS LONG
  128.     dfCopyright       AS STRING * 60
  129.     dfType            AS INTEGER
  130.     dfPoints          AS INTEGER
  131.     dfVertRes         AS INTEGER
  132.     dfHorizRes        AS INTEGER
  133.     dfAscent          AS INTEGER
  134.     dfInternalLeading AS INTEGER
  135.     dfExternalLeading AS INTEGER
  136.     dfItalic          AS STRING * 1
  137.     dfUnderline       AS STRING * 1
  138.     dfStrikeOut       AS STRING * 1
  139.     dfWeight          AS INTEGER
  140.     dfCharSet         AS STRING * 1
  141.     dfPixWidth        AS INTEGER
  142.     dfPixHeight       AS INTEGER
  143.     dfPitchAndFamily  AS STRING * 1
  144.     dfAvgWidth        AS INTEGER
  145.     dfMaxWidth        AS INTEGER
  146.     dfFirstChar       AS STRING * 1
  147.     dfLastChar        AS STRING * 1
  148.     dfDefaultChar     AS STRING * 1
  149.     dfBreakChar       AS STRING * 1
  150.     dfWidthBytes      AS INTEGER
  151.     dfDevice          AS LONG
  152.     dfFace            AS LONG
  153.     dfBitsPointer     AS LONG
  154.     dfBitsOffset      AS LONG
  155.     pad               AS STRING * 1  ' To ensure word boundry
  156. END TYPE
  157.  
  158. ' Structure for reading resource type and number from a resource
  159. ' table:
  160. TYPE ResType
  161.     TypeID            AS INTEGER
  162.     NumResource       AS INTEGER
  163.     Reserved          AS LONG
  164. END TYPE
  165.  
  166. ' Structure for reading an actual resource entry:
  167. TYPE ResEntry
  168.     AddrOffset        AS INTEGER
  169.     Length            AS INTEGER
  170.     ResourceKeywd     AS INTEGER
  171.     ResID             AS INTEGER
  172.     Reserved1         AS LONG
  173. END TYPE
  174.  
  175. ' Internal font header data type:
  176. TYPE IFontInfo
  177.     Status            AS INTEGER  ' Processing status. 0=unproc. else <>0
  178.     FontHeader        AS WFHeader ' The Windows font header
  179.     FaceName          AS STRING * cMaxFaceName   ' Font name
  180.     FileName          AS STRING * cMaxFileName   ' File name
  181.     FontSource        AS INTEGER  ' 0=file, 1=memory
  182.     FileLoc           AS LONG     ' Location in resource file of font file
  183.     DataSeg           AS INTEGER  ' FontData index or Segment address of font
  184.     DataOffset        AS INTEGER  ' Offset  address of font if in memory
  185.     BitsOffset        AS INTEGER  ' Offset from beginning of data to bitmaps
  186. END TYPE
  187.  
  188. ' Type for selecting registered fonts via LoadFont:
  189. TYPE FontSpec
  190.     FaceName    AS STRING * cMaxFaceName
  191.     Pitch       AS STRING * 1
  192.     PointSize   AS INTEGER     ' Fonts point size
  193.     HorizRes    AS INTEGER     ' Horizontal resolution of font
  194.     VertRes     AS INTEGER     ' Vertical resolution of font
  195.     ScrnMode    AS INTEGER     ' Screen mode
  196.     Height      AS INTEGER     ' Pixel height of font
  197.   
  198.     Best        AS INTEGER     ' "Best" flag (true/false)
  199.   
  200.     RegNum      AS INTEGER     ' Number of font in registered list
  201.   
  202.     InMemory    AS INTEGER     ' Whether font is in memory (true/false)
  203.     HdrSeg      AS INTEGER     ' Segment of font in memory
  204.     HdrOff      AS INTEGER     ' Offset of font in segment
  205.     DataSeg     AS INTEGER     ' Segment of data in memory
  206.     DataOff     AS INTEGER     ' Offset of data in segment
  207. END TYPE
  208.  
  209. ' Sub and Function Declarations:
  210.  
  211. DECLARE SUB flSetFontErr (ErrNum AS INTEGER)
  212. DECLARE SUB flClearFontErr ()
  213. DECLARE SUB flRegisterFont (FileName$, FileNum%)
  214. DECLARE SUB flReadFont (I%)
  215. DECLARE SUB flSizeFontBuffer (NFonts%)
  216. DECLARE SUB flInitSpec (Spec AS ANY)
  217. DECLARE SUB flClearFontStatus ()
  218. DECLARE SUB flGetCurrentScrnSize (XPixels%, YPixels%)
  219. DECLARE SUB flGetBASICScrnSize (ScrnMode%, XPixels%, YPixels%)
  220. DECLARE SUB flInitMask ()
  221. DECLARE SUB flPSET (X%, Y%, Colr%)
  222. DECLARE SUB flChkMax ()
  223.  
  224. DECLARE FUNCTION flGetFonts! (NFonts%)
  225. DECLARE FUNCTION flMatchFont! (FSpec AS ANY)
  226. DECLARE FUNCTION flGetNum! (Txt$, ChPos%, Default!, ErrV!)
  227. DECLARE FUNCTION flGetNextSpec! (SpecTxt$, ChPos%, Spec AS ANY)
  228. DECLARE FUNCTION flDoNextResource! (Align%, FileName$, FileNum%)
  229. DECLARE FUNCTION flOutGChar% (X%, Y%, ChVal%)
  230.  
  231. ' -- Assembly language routines
  232. DECLARE SUB flMovMem ALIAS "fl_MovMem" (SEG dest AS ANY, BYVAL SrcSeg AS INTEGER, BYVAL SrcOffset AS INTEGER, BYVAL Count AS INTEGER)
  233. DECLARE FUNCTION flANSI% ALIAS "fl_ansi" (BYVAL I%)
  234.  
  235. DECLARE SUB flSetBltDir ALIAS "fl_SetBltDir" (BYVAL XPixInc%, BYVAL YPixInc%, BYVAL XRowInc%, BYVAL YRowInc%)
  236. DECLARE SUB flSetBltColor ALIAS "fl_SetBltColor" (BYVAL CharColor%)
  237. DECLARE SUB flSetBltParams ALIAS "fl_SetBltParams" (BYVAL HdrLen%, BYVAL CharHgt%, BYVAL FirstChar%, BYVAL LastChar%, BYVAL DefaultChar%)
  238. DECLARE FUNCTION flbltchar% ALIAS "fl_BltChar" (BYVAL FASeg%, BYVAL FAOffset%, BYVAL Char%, BYVAL X%, BYVAL Y%)
  239.  
  240. ' Variable Definitions:
  241.  
  242. ' The following arrays hold font headers and font data as fonts are
  243. ' registered and loaded. They are dynamically allocated so they can be
  244. ' changed in size to accomodate the number of fonts a program will be
  245. ' using:
  246.  
  247. ' $DYNAMIC
  248.  
  249. ' Array to hold header information for registered fonts:
  250. DIM SHARED FontHdrReg(1 TO 10)  AS IFontInfo
  251.  
  252. ' Arrays to hold header information and registered font numbers
  253. ' for loaded fonts:
  254. DIM SHARED FontHdrLoaded(1 TO 10) AS IFontInfo
  255. DIM SHARED FontLoadList(1 TO 10) AS INTEGER
  256.  
  257. ' Array to hold font data information:
  258. DIM SHARED FontData(1 TO 1) AS FontDataBlock
  259.  
  260. ' $STATIC
  261.  
  262. ' Structure holding global parameters:
  263. DIM SHARED FGP AS GlobalParams
  264.  
  265. ' Module level code:
  266.  
  267. ' Error handler for flChkMax so these arrays will be dimensioned
  268. ' to 10 by default:
  269. SetMax:
  270.     REDIM FontHdrLoaded(1 TO 10) AS IFontInfo
  271.     REDIM FontHdrReg(1 TO 10) AS IFontInfo
  272.     REDIM FontLoadList(1 TO 10) AS INTEGER
  273.     RESUME
  274.  
  275. ' Error handler for out of memory error:
  276. MemErr:
  277.     flSetFontErr cNoFontMem
  278.     RESUME NEXT
  279.  
  280. ' Error handler for unexpected errors:
  281. UnexpectedErr:
  282.     flSetFontErr cFLUnexpectedErr + ERR
  283.     RESUME NEXT
  284.  
  285. ' File not found error: RegisterFonts
  286. NoFileErr:
  287.     flSetFontErr cFileNotFound
  288.     RESUME NEXT
  289.  
  290. '=== flChkMax - Makes sure that max font settings are correct and
  291. '                enforces default of 10 for max loaded and registered
  292. '
  293. '  Arguments:
  294. '     none
  295. '
  296. '  Return Values:
  297. '     none
  298. '
  299. '=================================================================
  300. STATIC SUB flChkMax ()
  301. SHARED FontHdrLoaded() AS IFontInfo
  302. SHARED FontHdrReg() AS IFontInfo
  303. SHARED FGP AS GlobalParams
  304.  
  305. ' Make sure that GP.MaxLoaded and GP.MaxRegistered match array dimensions
  306. ' this will only happen if user hasn't used SetMaxFonts and allows Fontlib
  307. ' to set a default of 10 since that is what the arrays are first DIM'd
  308. ' to:
  309.  
  310. ON ERROR GOTO SetMax
  311. FGP.MaxLoaded = UBOUND(FontHdrLoaded)
  312. FGP.MaxRegistered = UBOUND(FontHdrReg)
  313. ON ERROR GOTO UnexpectedErr
  314.  
  315. END SUB
  316.  
  317. '=== flClearFontErr - Sets the FontErr variable to 0
  318. '
  319. '  Arguments:
  320. '     none
  321. '
  322. '  Return Values:
  323. '     none
  324. '
  325. '=================================================================
  326. STATIC SUB flClearFontErr ()
  327.  
  328.     FontErr = 0
  329.  
  330. END SUB
  331.  
  332. '=== flClearFontStatus - Clears the status field in the registered font list
  333. '
  334. '  Arguments:
  335. '     none
  336. '
  337. '=================================================================
  338. STATIC SUB flClearFontStatus ()
  339. SHARED FGP AS GlobalParams
  340. SHARED FontHdrReg() AS IFontInfo
  341.  
  342. FOR I% = 1 TO FGP.TotalRegistered
  343.     FontHdrReg(I%).Status = 0
  344. NEXT I%
  345.  
  346. END SUB
  347.  
  348. '=== flDoNextResource - Processes resource from resource table:
  349. '
  350. '  Arguments:
  351. '     Align%      - Alignment shift count for finding resource data
  352. '
  353. '     FileName$   - Name of font file (passed to routine that actually
  354. '                   registers resource entry)
  355. '
  356. '     FileNum%    - File number for reading
  357. '
  358. '  Return Value:
  359. '     The number of fonts actually registered
  360. '
  361. '=================================================================
  362. STATIC FUNCTION flDoNextResource (Align%, FileName$, FileNum%)
  363. DIM ResID AS ResType, Entry AS ResEntry
  364.  
  365. ' Get the first few bytes identifying the resource type and the number
  366. ' of this type:
  367. GET FileNum%, , ResID
  368.  
  369. ' If this is not the last resource then process it:
  370. IF ResID.TypeID <> 0 THEN
  371.  
  372.     ' Loop through the entries of this resource and if an entry happens to be
  373.     ' a font resource then register it. The file location must be saved
  374.     ' for each entry in the resource table since the flRegisterFont
  375.     ' routine may go to some other part of the file to read the resource:
  376.     FOR ResourceEntry = 1 TO ResID.NumResource
  377.       
  378.         GET FileNum%, , Entry
  379.         NextResLoc# = SEEK(FileNum%)
  380.         IF ResID.TypeID = cFontResource THEN
  381.              
  382.             ' Seek to font information, register it, then seek back to
  383.             ' the next resource table entry:
  384.             SEEK FileNum%, Entry.AddrOffset * 2 ^ Align% + 1
  385.             flRegisterFont FileName$, FileNum%
  386.             SEEK FileNum%, NextResLoc#
  387.             IF FontErr <> 0 THEN EXIT FUNCTION
  388.  
  389.         END IF
  390.         
  391.     NEXT ResourceEntry
  392. END IF
  393.  
  394. ' Return the current resource type so that RegisterFonts knows when the
  395. ' last resource has been read:
  396. flDoNextResource = ResID.TypeID
  397.  
  398. END FUNCTION
  399.  
  400. '=== flGetBASICScrnSize - Returns screen size for specified BASIC screen mode
  401. '
  402. '  Arguments:
  403. '
  404. '     ScrnMode%   -  BASIC screen mode
  405. '
  406. '     XPixels%    -  Number of pixels in horizontal direction
  407. '
  408. '     YPixels%    -  Number of pixels in vertical direction
  409. '
  410. '=================================================================
  411. STATIC SUB flGetBASICScrnSize (ScrnMode%, XPixels%, YPixels%)
  412.     SELECT CASE ScrnMode%
  413.         CASE 1: XPixels% = 320: YPixels% = 200
  414.         CASE 2: XPixels% = 640: YPixels% = 200
  415.         CASE 3: XPixels% = 720: YPixels% = 348
  416.         CASE 4: XPixels% = 640: YPixels% = 400
  417.         CASE 7: XPixels% = 320: YPixels% = 200
  418.         CASE 8: XPixels% = 640: YPixels% = 200
  419.         CASE 9: XPixels% = 640: YPixels% = 350
  420.         CASE 10: XPixels% = 640: YPixels% = 350
  421.         CASE 11: XPixels% = 640: YPixels% = 480
  422.         CASE 12: XPixels% = 640: YPixels% = 480
  423.         CASE 13: XPixels% = 320: YPixels% = 200
  424.         CASE ELSE: XPixels% = 0: YPixels% = 0
  425.     END SELECT
  426. END SUB
  427.  
  428. '=== flGetCurrentScrnSize - Returns screen size for current screen mode
  429. '
  430. '  Arguments:
  431. '
  432. '     XPixels%    -  Number of pixels in horizontal direction
  433. '
  434. '     YPixels%    -  Number of pixels in vertical direction
  435. '
  436. '=================================================================
  437. STATIC SUB flGetCurrentScrnSize (XPixels%, YPixels%)
  438. DIM Regs AS RegType
  439.  
  440. ' Use DOS interrupt to get current video display mode:
  441. Regs.ax = &HF00
  442. CALL INTERRUPT(&H10, Regs, Regs)
  443.  
  444. ' Set screen size based on mode:
  445. SELECT CASE Regs.ax MOD 256
  446.     CASE &H4: XPixels% = 320: YPixels% = 200
  447.     CASE &H5: XPixels% = 320: YPixels% = 200
  448.     CASE &H6: XPixels% = 640: YPixels% = 200
  449.     CASE &H7: XPixels% = 720: YPixels% = 350
  450.     CASE &H8: XPixels% = 720: YPixels% = 348     ' Hercules
  451.     CASE &HD: XPixels% = 320: YPixels% = 200
  452.     CASE &HE: XPixels% = 640: YPixels% = 200
  453.     CASE &HF: XPixels% = 640: YPixels% = 350
  454.     CASE &H10: XPixels% = 640: YPixels% = 350
  455.     CASE &H11: XPixels% = 640: YPixels% = 480
  456.     CASE &H12: XPixels% = 640: YPixels% = 480
  457.     CASE &H13: XPixels% = 320: YPixels% = 200
  458.     CASE &H40: XPixels% = 640: YPixels% = 400    ' Olivetti
  459.     CASE ELSE: XPixels% = 0: YPixels = 0
  460. END SELECT
  461. END SUB
  462.  
  463. '=== flGetFonts - Gets fonts specified in FontLoadList
  464. '
  465. '  Arguments:
  466. '     NFonts%  -  Number of fonts to load
  467. '
  468. '  Return Values:
  469. '     Number of fonts successfully loaded
  470. '
  471. '=================================================================
  472. STATIC FUNCTION flGetFonts (NFonts%)
  473. SHARED FGP AS GlobalParams
  474. SHARED FontHdrReg() AS IFontInfo
  475. SHARED FontHdrLoaded() AS IFontInfo
  476. SHARED FontLoadList() AS INTEGER
  477.  
  478. ' Re-dimension font data buffer to fit all the fonts:
  479. flSizeFontBuffer (NFonts%)
  480. IF FontErr = cNoFontMem THEN EXIT FUNCTION
  481.  
  482. ' Clear the font status variables then load the fonts (the status variable
  483. ' is used to record which ones have already been loaded so they aren't
  484. ' loaded more than once):
  485. flClearFontStatus
  486. FOR Font% = 1 TO NFonts%
  487.     FontNum% = FontLoadList(Font%)
  488.  
  489.     ' If font already loaded then just copy the already-filled-out header
  490.     ' to the new slot:
  491.     IF FontHdrReg(FontNum%).Status <> 0 THEN
  492.         FontHdrLoaded(Font%) = FontHdrLoaded(FontHdrReg(FontNum%).Status)
  493.   
  494.     ' Otherwise, read the font and update status in registered version
  495.     ' to point to the first slot it was loaded into (so we can go get
  496.     ' an already-filled-out header from there):
  497.     ELSE
  498.         FontHdrLoaded(Font%) = FontHdrReg(FontNum%)
  499.       
  500.         ' Hold any existing errors:
  501.         HoldErr% = FontErr
  502.         flClearFontErr
  503.  
  504.         flReadFont Font%
  505.       
  506.         ' If there was an error in reading font, exit. Otherwise,
  507.         ' reset the error to what it was before and continue:
  508.         IF FontErr <> 0 THEN
  509.             flGetFonts = FontNum% - 1
  510.             EXIT FUNCTION
  511.         ELSE
  512.             flSetFontErr HoldErr%
  513.         END IF
  514.  
  515.         FontHdrReg(FontNum%).Status = Font%
  516.     END IF
  517. NEXT Font%
  518.  
  519. flGetFonts = NFonts%
  520. END FUNCTION
  521.  
  522. '=== flGetNextSpec - Parses the next spec from the spec string
  523. '
  524. '  Arguments:
  525. '     SpecTxt$ -  String containing font specifications
  526. '
  527. '     ChPos%   -  Current position in string (updated in this routine)
  528. '
  529. '     Spec     -  Structure to contain parsed values
  530. '
  531. '
  532. '  Return Values:
  533. '     0    -  Spec was found
  534. '
  535. '     1    -  No spec found
  536. '
  537. '     2    -  Invalid spec found
  538. '=================================================================
  539. STATIC FUNCTION flGetNextSpec (SpecTxt$, ChPos%, Spec AS FontSpec)
  540.  
  541. ' Initialize some things:
  542. SpecErr = cFALSE
  543. SpecLen% = LEN(SpecTxt$)
  544.  
  545. ' If character pos starts past end of spec then we're done:
  546. IF ChPos% > SpecLen% THEN
  547.     flGetNextSpec = 1
  548.     EXIT FUNCTION
  549. END IF
  550.  
  551. DO UNTIL ChPos% > SpecLen%
  552.  
  553.     Param$ = UCASE$(MID$(SpecTxt$, ChPos%, 1))
  554.     ChPos% = ChPos% + 1
  555.  
  556.     SELECT CASE Param$
  557.  
  558.         ' Skip blanks:
  559.         CASE " ":
  560.  
  561.         ' Font title:
  562.         CASE "T":
  563.           
  564.             ' Scan for font title until blank or end of string:
  565.             StartPos% = ChPos%
  566.             DO UNTIL ChPos% > SpecLen%
  567.                 Char$ = MID$(SpecTxt$, ChPos%, 1)
  568.                 ChPos% = ChPos% + 1
  569.             LOOP
  570.           
  571.             ' Extract the title:
  572.             TitleLen% = ChPos% - StartPos%
  573.             IF TitleLen% <= 0 THEN
  574.                 SpecErr = cTRUE
  575.             ELSE
  576.                 Spec.FaceName = MID$(SpecTxt$, StartPos%, TitleLen%)
  577.             END IF
  578.  
  579.         ' Fixed or Proportional font:
  580.         CASE "F", "P":
  581.             Spec.Pitch = Param$
  582.  
  583.         ' Font Size (default to 12 points):
  584.         CASE "S":
  585.             Spec.PointSize = flGetNum(SpecTxt$, ChPos%, 12, SpecErr)
  586.  
  587.         ' Screen Mode:
  588.         CASE "M":
  589.             Spec.ScrnMode = flGetNum(SpecTxt$, ChPos%, -1, SpecErr)
  590.  
  591.         ' Pixel Height:
  592.         CASE "H":
  593.             Spec.Height = flGetNum(SpecTxt$, ChPos%, 0, SpecErr)
  594.  
  595.         ' Best fit:
  596.         CASE "B":
  597.             Spec.Best = cTRUE
  598.  
  599.         ' Registered font number:
  600.         CASE "N":
  601.             Spec.RegNum = flGetNum(SpecTxt$, ChPos%, 0, SpecErr)
  602.  
  603.         ' Font in memory:
  604.         CASE "R":
  605.             Spec.InMemory = cTRUE
  606.  
  607.         ' Spec separator:
  608.         CASE "/":
  609.             EXIT DO
  610.  
  611.         ' Anything else is an error:
  612.         CASE ELSE:
  613.             SpecErr = cTRUE
  614.             ChPos% = ChPos% + 1
  615.     END SELECT
  616. LOOP
  617.  
  618. ' Spec is parsed, make sure a valid screen mode has been specified and
  619. ' adjust point sizes for 320x200 screens if necessary:
  620. IF Spec.PointSize <> 0 THEN
  621.   
  622.     ' Get screen size for specified mode (with "M" param) or current
  623.     ' screen mode:
  624.     IF Spec.ScrnMode < 0 THEN
  625.         flGetCurrentScrnSize XPixels%, YPixels%
  626.     ELSE
  627.         flGetBASICScrnSize Spec.ScrnMode, XPixels%, YPixels%
  628.     END IF
  629.  
  630.     ' If this isn't a graphics mode then set an error and skip the rest:
  631.     IF XPixels% = 0 THEN
  632.         SpecErr = cTRUE
  633.         Spec.PointSize = 0
  634.  
  635.     ' If this is a 320x200 screen mode adjust point sizes to the
  636.     ' equivalent EGA font point sizes. Also set the horizontal
  637.     ' a vertical resolutions to search for in fonts (horizontal is
  638.     ' 96 for all modes, vertical varies):
  639.     ELSE
  640.       
  641.         ' Use a horizontal resolution of 96 for all screens:
  642.         Spec.HorizRes = 96
  643.  
  644.         IF XPixels% = 320 THEN
  645.             Spec.VertRes = 72
  646.           
  647.             ' In a 320x200 mode scale point sizes to their equivalent
  648.             ' EGA fonts (special case 14 and 24 point fonts to map them
  649.             ' to the closest EGA font otherwise multiply point size by
  650.             ' 2/3:
  651.             SELECT CASE Spec.PointSize
  652.                 CASE 14: Spec.PointSize = 10
  653.                 CASE 24: Spec.PointSize = 18
  654.                 CASE ELSE: Spec.PointSize = Spec.PointSize * 2 / 3
  655.             END SELECT
  656.  
  657.         ELSE
  658.           
  659.             ' Other screen modes vary only in vertical resolution:
  660.             SELECT CASE YPixels%
  661.                 CASE 200: Spec.VertRes = 48
  662.                 CASE 350: Spec.VertRes = 72
  663.                 CASE 480: Spec.VertRes = 96
  664.             END SELECT
  665.         END IF
  666.     END IF
  667. END IF
  668.  
  669. ' If an error was found somewhere then pass it on and set-up to load
  670. ' first font:
  671. IF SpecErr THEN
  672.     flGetNextSpec = 2
  673.     Spec.RegNum = 1
  674. ELSE
  675.     flGetNextSpec = 0
  676. END IF
  677.  
  678. END FUNCTION
  679.  
  680. '=== flGetNum - Parses number from string
  681. '
  682. '  Arguments:
  683. '     Txt$     -  String from which to parse number
  684. '
  685. '     ChPos%   -  Character position on which to start
  686. '
  687. '     Default  -  Default value if number not found
  688. '
  689. '     ErrV     -  Returns error as cTrue or cFalse
  690. '
  691. '  Return Values:
  692. '     Returns value found or default
  693. '
  694. '  Notes:
  695. '     Simple state machine:
  696. '        state 0: Looking for first char
  697. '        state 1: Found start (+, -, or digit)
  698. '        state 2: Done
  699. '        state 3: Error
  700. '
  701. '=================================================================
  702. STATIC FUNCTION flGetNum (Txt$, ChPos%, Default, ErrV)
  703.  
  704. ' Start in state 0
  705. State = 0
  706.  
  707. ' Loop until done
  708. DO
  709.     Char$ = MID$(Txt$, ChPos%, 1)
  710.     SELECT CASE Char$
  711.  
  712.         ' Plus and minus are only OK at the beginning:
  713.         CASE "+", "-":
  714.             SELECT CASE State
  715.                 CASE 0: Start% = ChPos%: State = 1
  716.                 CASE ELSE: State = 3
  717.             END SELECT
  718.  
  719.         ' Digits are OK at the beginning of after plus and minus:
  720.         CASE "0" TO "9":
  721.             SELECT CASE State
  722.                 CASE 0: Start% = ChPos%: State = 1
  723.                 CASE ELSE:
  724.             END SELECT
  725.  
  726.         ' Spaces are skipped:
  727.         CASE " ":
  728.  
  729.         ' Anything else is an error at the beginning or marks the end:
  730.         CASE ELSE:
  731.             SELECT CASE State
  732.                 CASE 0: State = 3
  733.                 CASE 1: State = 2
  734.             END SELECT
  735.     END SELECT
  736.  
  737.     ' Go to next character:
  738.     ChPos% = ChPos% + 1
  739. LOOP UNTIL State = 2 OR State = 3
  740.  
  741. ' Scanning is complete; adjust ChPos% to mark last character processed:
  742. ChPos% = ChPos% - 1
  743.  
  744. ' If error then set default number:
  745. IF State = 3 THEN
  746.     flGetNum = Default
  747.     ErrV = cTRUE
  748.  
  749. ' Otherwise, extract number and get its value:
  750. ELSE
  751.     EndPos% = ChPos% - 1
  752.     flGetNum = VAL(MID$(Txt$, Start%, EndPos%))
  753.     ErrV = cFALSE
  754. END IF
  755. END FUNCTION
  756.  
  757. '=== flInitSpec - Initializes font specification structure
  758. '
  759. '  Arguments:
  760. '     Spec     -  FontSpec variable to initialize
  761. '
  762. '=================================================================
  763. STATIC SUB flInitSpec (Spec AS FontSpec)
  764.  
  765.     Spec.FaceName = ""
  766.     Spec.Pitch = ""
  767.     Spec.PointSize = 0
  768.     Spec.ScrnMode = -1
  769.     Spec.Height = 0
  770.     Spec.Best = cFALSE
  771.     Spec.RegNum = 0
  772.     Spec.InMemory = cFALSE
  773.  
  774. END SUB
  775.  
  776. '=== flMatchFont - Finds first registered font that matches FontSpec
  777. '
  778. '  Arguments:
  779. '     FSpec -  FontSpec variable containing specification to match
  780. '
  781. '  Return Values:
  782. '     Number of registered font matched, -1 if no match.
  783. '
  784. '=================================================================
  785. STATIC FUNCTION flMatchFont (FSpec AS FontSpec)
  786. SHARED FGP AS GlobalParams
  787. SHARED FontHdrReg() AS IFontInfo
  788.  
  789. ' Match a specific registered font:
  790. IF FSpec.RegNum > 0 AND FSpec.RegNum <= FGP.TotalRegistered THEN
  791.     flMatchFont = FSpec.RegNum
  792.     EXIT FUNCTION
  793. END IF
  794.  
  795. ' If this is an invalid spec. then no fonts matched:
  796. IF FontErr <> 0 THEN
  797.     flMatchFont = -1
  798.     EXIT FUNCTION
  799. END IF
  800.  
  801. ' Scan font for first one that matches the rest of the specs:
  802. SelectedFont% = -1
  803. BestSizeDiff = 3.402823E+38
  804. BestFontNum% = -1
  805. FOR FontNum% = 1 TO FGP.TotalRegistered
  806.  
  807.     ' Match a font from memory:
  808.     MemOK% = cTRUE
  809.     IF FSpec.InMemory AND FontHdrReg(FontNum%).FontSource <> cMemFont THEN
  810.         MemOK% = cFALSE
  811.     END IF
  812.   
  813.     ' Match name:
  814.     IF FSpec.FaceName = FontHdrReg(FontNum%).FaceName OR LTRIM$(FSpec.FaceName) = "" THEN
  815.         NameOK% = cTRUE
  816.     ELSE
  817.         NameOK% = cFALSE
  818.     END IF
  819.  
  820.     ' Match pitch (fixed or proportional):
  821.     Pitch$ = "F"
  822.     IF FontHdrReg(FontNum%).FontHeader.dfPixWidth = 0 THEN Pitch$ = "P"
  823.     IF FSpec.Pitch = Pitch$ OR FSpec.Pitch = " " THEN
  824.         PitchOK% = cTRUE
  825.     ELSE
  826.         PitchOK% = cFALSE
  827.     END IF
  828.  
  829.     ' Match font size (if neither point or pixel size specified then
  830.     ' this font is OK):
  831.     IF FSpec.PointSize = 0 AND FSpec.Height = 0 THEN
  832.         SizeOK% = cTRUE
  833.   
  834.     ' Otherwise, if point size specified (note that point size overrides
  835.     ' the pixel height if they were both specified)...
  836.     ELSEIF FSpec.PointSize <> 0 THEN
  837.       
  838.         ' Make sure the font resolution matches the screen resolution
  839.         ' (pass over this font if not):
  840.         IF FSpec.HorizRes <> FontHdrReg(FontNum%).FontHeader.dfHorizRes THEN
  841.             SizeOK% = cFALSE
  842.         ELSEIF FSpec.VertRes <> FontHdrReg(FontNum%).FontHeader.dfVertRes THEN
  843.             SizeOK% = cFALSE
  844.       
  845.         ' Font has made it past the resolution check, now try to match size:
  846.         ELSE
  847.             SizeDiff = ABS(FSpec.PointSize - FontHdrReg(FontNum%).FontHeader.dfPoints)
  848.             IF SizeDiff = 0 THEN
  849.                 SizeOK% = cTRUE
  850.             ELSE
  851.                 SizeOK% = cFALSE
  852.             END IF
  853.         END IF
  854.  
  855.  
  856.     ' Now, the case where height was specified and not point size:
  857.     ELSEIF FSpec.Height <> 0 THEN
  858.         SizeDiff = ABS(FSpec.Height - FontHdrReg(FontNum%).FontHeader.dfPixHeight)
  859.         IF SizeDiff = 0 THEN
  860.             SizeOK% = cTRUE
  861.         ELSE
  862.             SizeOK% = cFALSE
  863.         END IF
  864.     END IF
  865.  
  866.     ' Do record keeping if best-fit was specified:
  867.     IF NOT SizeOK% AND PitchOK% AND FSpec.Best AND SizeDiff < BestSizeDiff THEN
  868.         BestSizeDiff = SizeDiff
  869.         BestFontNum% = FontNum%
  870.     END IF
  871.  
  872.     ' See if this font is OK:
  873.     IF MemOK% AND NameOK% AND PitchOK% AND SizeOK% THEN
  874.         SelectedFont% = FontNum%
  875.         EXIT FOR
  876.     END IF
  877. NEXT FontNum%
  878.  
  879. ' If no font was matched and best-fit was specified then select the
  880. ' best font:
  881. IF SelectedFont% < 0 AND FSpec.Best THEN SelectedFont% = BestFontNum%
  882.  
  883. ' Return the font matched:
  884. flMatchFont = SelectedFont%
  885.  
  886. END FUNCTION
  887.  
  888. '=== flReadFont - Reads font data and sets up font header
  889. '
  890. '  Arguments:
  891. '     I%    -  Slot in loaded fonts to process
  892. '
  893. '=================================================================
  894. STATIC SUB flReadFont (I%)
  895. SHARED FGP AS GlobalParams
  896. SHARED FontHdrLoaded() AS IFontInfo
  897. SHARED FontData() AS FontDataBlock
  898.  
  899. ON ERROR GOTO UnexpectedErr
  900.  
  901. ' If memory font then it's already in memory:
  902. IF FontHdrLoaded(I%).FontSource = cMemFont THEN
  903.     EXIT SUB
  904.  
  905. ' For a font from a file, read it in:
  906. ELSE
  907.     DataSize# = FontHdrLoaded(I%).FontHeader.dfSize - cSizeFontHeader
  908.     NumBlocks% = -INT(-DataSize# / cFontBlockSize)
  909.     FontHdrLoaded(I%).DataSeg = FGP.NextDataBlock
  910.  
  911.     ' Get next available file number and open file:
  912.     FileNum% = FREEFILE
  913.     OPEN FontHdrLoaded(I%).FileName FOR BINARY AS FileNum%
  914.  
  915.     ' Read blocks from the font file:
  916.     DataLoc# = FontHdrLoaded(I%).FileLoc + cSizeFontHeader
  917.     SEEK FileNum%, DataLoc#
  918.     FOR BlockNum% = 0 TO NumBlocks% - 1
  919.         GET FileNum%, , FontData(FGP.NextDataBlock + BlockNum%)
  920.     NEXT BlockNum%
  921.   
  922.     ' Close the file:
  923.     CLOSE FileNum%
  924.  
  925.     ' Update the next data block pointer:
  926.     FGP.NextDataBlock = FGP.NextDataBlock + NumBlocks%
  927. END IF
  928.  
  929. END SUB
  930.  
  931. '=== flRegisterFont - Actually registers a font resource:
  932. '
  933. '  Arguments:
  934. '     FileName$   - Name of font file (passed to routine that actually
  935. '                   registers resource entry)
  936. '
  937. '     FileNum%    - File number for reading
  938. '
  939. '=================================================================
  940. STATIC SUB flRegisterFont (FileName$, FileNum%)
  941. SHARED FGP AS GlobalParams
  942. SHARED FontHdrReg() AS IFontInfo
  943.  
  944. DIM Byte AS STRING * 1, FontHeader AS WFHeader
  945.  
  946. ' Read the font header:
  947. FontLoc# = SEEK(FileNum%)
  948. GET FileNum%, , FontHeader
  949.  
  950. ' Only register vector fonts:
  951. IF FontHeader.dfType AND &H1 <> cBitMapType THEN EXIT SUB
  952.  
  953. ' See that we're still within MaxRegistered limits:
  954. IF FGP.TotalRegistered >= FGP.MaxRegistered THEN
  955.     flSetFontErr cTooManyFonts
  956.     EXIT SUB
  957. END IF
  958.  
  959. ' Go to next "registered" font slot:
  960. FGP.TotalRegistered = FGP.TotalRegistered + 1
  961.  
  962. ' Set font source and save the header and file location:
  963. FontHdrReg(FGP.TotalRegistered).FontSource = cFileFont
  964. FontHdrReg(FGP.TotalRegistered).FontHeader = FontHeader
  965. FontHdrReg(FGP.TotalRegistered).FileLoc = FontLoc#
  966.  
  967. ' Get the face name (scan characters until zero byte):
  968. SEEK FileNum%, FontLoc# + FontHeader.dfFace
  969. FaceName$ = ""
  970. FOR Char% = 0 TO cMaxFaceName - 1
  971.     GET FileNum%, , Byte
  972.     IF ASC(Byte) = 0 THEN EXIT FOR
  973.     FaceName$ = FaceName$ + Byte
  974. NEXT Char%
  975. FontHdrReg(FGP.TotalRegistered).FaceName = FaceName$
  976.  
  977. ' Finally, save the file name:
  978. FontHdrReg(FGP.TotalRegistered).FileName = FileName$
  979.  
  980. END SUB
  981.  
  982. '=== flSetFontErr - Sets the FontErr variable to an error value:
  983. '
  984. '  Arguments:
  985. '     ErrNum   -  The error number to set FontErr variable to
  986. '
  987. '=================================================================
  988. STATIC SUB flSetFontErr (ErrNum AS INTEGER)
  989.  
  990.      FontErr = ErrNum
  991.  
  992. END SUB
  993.  
  994. '=== flSizeFontBuffer - Calculate the FontBuffer size required for all fonts
  995. '
  996. '  Arguments:
  997. '     NFonts%  -  Number of font to be loaded
  998. '
  999. '  Notes:
  1000. '     The use of -INT(-N) in the following code rounds N to the next
  1001. '     larger integer
  1002. '
  1003. '=================================================================
  1004. STATIC SUB flSizeFontBuffer (NFonts%)
  1005. SHARED FGP AS GlobalParams
  1006. SHARED FontHdrReg() AS IFontInfo
  1007. SHARED FontLoadList() AS INTEGER
  1008. SHARED FontData() AS FontDataBlock
  1009.  
  1010.  
  1011. ON ERROR GOTO UnexpectedErr
  1012. IF NFonts% = 0 THEN EXIT SUB
  1013.  
  1014. ' Clear font status variables so we know what has been processed:
  1015. flClearFontStatus
  1016.  
  1017. ' Add sizes of all unique fonts together to get total size (each font
  1018. ' begins on a new font block so the size of each font is calculated in
  1019. ' terms of the number of font blocks it will take up):
  1020. Size = 0
  1021. FOR I% = 1 TO NFonts%
  1022.     FontNum% = FontLoadList(I%)
  1023.     IF FontHdrReg(FontNum%).Status = 0 THEN
  1024.         FontSize = FontHdrReg(FontNum%).FontHeader.dfSize - cSizeFontHeader
  1025.         Size = Size - INT(-FontSize / cFontBlockSize)
  1026.         FontHdrReg(FontNum%).Status = 1
  1027.     END IF
  1028. NEXT I%
  1029.  
  1030. ' Dimension the FontData array to hold everything:
  1031. ON ERROR GOTO MemErr
  1032. REDIM FontData(1 TO Size) AS FontDataBlock
  1033. ON ERROR GOTO UnexpectedErr
  1034.  
  1035. ' Set the next font block to the start for when flReadFont begins
  1036. ' putting data in the font buffer:
  1037. FGP.NextDataBlock = 1
  1038.  
  1039. END SUB
  1040.  
  1041. '=== GetFontInfo - Returns useful information about current font
  1042. '
  1043. '  Arguments:
  1044. '     FI    -  FontInfo type variable to receive info
  1045. '
  1046. '=================================================================
  1047. STATIC SUB GetFontInfo (FI AS FontInfo)
  1048. SHARED FGP AS GlobalParams
  1049. SHARED FontHdrLoaded() AS IFontInfo
  1050.  
  1051. ON ERROR GOTO UnexpectedErr
  1052.  
  1053. ' Clear outstanding font errors:
  1054. flClearFontErr
  1055.  
  1056. ' Check that some fonts are loaded:
  1057. IF FGP.TotalLoaded <= 0 THEN
  1058.     flSetFontErr cNoFonts
  1059.     EXIT SUB
  1060. END IF
  1061.  
  1062. ' All OK, assign values from internal font header:
  1063. FI.FontNum = FGP.CurrentFont
  1064. FI.Ascent = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfAscent
  1065. FI.Points = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPoints
  1066. FI.PixWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixWidth
  1067. FI.PixHeight = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixHeight
  1068. FI.Leading = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfInternalLeading
  1069. FI.MaxWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfMaxWidth
  1070. FI.AvgWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfAvgWidth
  1071. FI.FileName = FontHdrLoaded(FGP.CurrentFont).FileName
  1072. FI.FaceName = FontHdrLoaded(FGP.CurrentFont).FaceName
  1073.  
  1074. END SUB
  1075.  
  1076. '=== GetGTextLen - Returns bit length of string
  1077. '
  1078. '  Arguments:
  1079. '     Text$ -  String for which to return length
  1080. '
  1081. '  Return Values:
  1082. '     -1    -  Error (No fonts loaded, probably)
  1083. '
  1084. '     >=0   -  Length of string
  1085. '
  1086. '=================================================================
  1087. STATIC FUNCTION GetGTextLen% (Text$)
  1088. SHARED FGP AS GlobalParams
  1089. SHARED FontHdrLoaded() AS IFontInfo
  1090. SHARED FontData() AS FontDataBlock
  1091.  
  1092. ON ERROR GOTO UnexpectedErr
  1093.  
  1094. ' Clear outstanding font errors:
  1095. flClearFontErr
  1096.  
  1097. ' Make sure some fonts are loaded:
  1098. IF FGP.TotalLoaded <= 0 THEN
  1099.     flSetFontErr cNoFonts
  1100.     GetGTextLen = -1
  1101.     EXIT FUNCTION
  1102. END IF
  1103.  
  1104. ' Assume this is a memory font (may override this later):
  1105. CharTblPtr% = FontHdrLoaded(FGP.CurrentFont).DataOffset
  1106. CharTblSeg% = FontHdrLoaded(FGP.CurrentFont).DataSeg
  1107.  
  1108. ' Index into font data array:
  1109. CharTable% = FontHdrLoaded(FGP.CurrentFont).DataSeg
  1110.  
  1111. ' Add together the character lengths from the character table:
  1112. TextLen% = 0
  1113. FOR I% = 1 TO LEN(Text$)
  1114.   
  1115.     ' Get character code and translate to Ansi if IBM char set is specified:
  1116.     ChVal% = ASC(MID$(Text$, I%, 1))
  1117.     IF FGP.CharSet = cIBMChars THEN ChVal% = flANSI(ChVal%)
  1118.   
  1119.     ' Convert to default char if out of range:
  1120.     IF ChVal% < FGP.FChar OR ChVal% > FGP.LChar THEN ChVal% = FGP.DChar%
  1121.   
  1122.     ' Offset into character table for length word:
  1123.     CharOffset% = (ChVal% - FGP.FChar) * 4
  1124.  
  1125.     ' Peek the data and add it to the text length:
  1126.     IF FontHdrLoaded(FGP.CurrentFont).FontSource = cFileFont THEN
  1127.         CharTblPtr% = VARPTR(FontData(CharTable%))
  1128.         CharTblSeg% = VARSEG(FontData(CharTable%))
  1129.     END IF
  1130.     DEF SEG = CharTblSeg%
  1131.     CharLen% = PEEK(CharTblPtr% + CharOffset%) + PEEK(CharTblPtr% + CharOffset% + 1) * 256
  1132.     TextLen% = TextLen% + CharLen%
  1133. NEXT I%
  1134.  
  1135. GetGTextLen = TextLen%
  1136.  
  1137. END FUNCTION
  1138.  
  1139. '=== GetMaxFonts - Gets the maximum number of fonts that can be registered
  1140. '                  and loaded by the font library:
  1141. '
  1142. '  Arguments:
  1143. '     Registered  -  The maximum number of fonts that can be registered
  1144. '                    by the font library
  1145. '
  1146. '     Loaded      -  The maximum number of fonts that can be loaded by
  1147. '                    by the font library
  1148. '
  1149. '=================================================================
  1150. SUB GetMaxFonts (Registered AS INTEGER, Loaded AS INTEGER)
  1151. SHARED FGP AS GlobalParams
  1152.  
  1153. ON ERROR GOTO UnexpectedErr
  1154.  
  1155. ' Clear outstanding font errors:
  1156. flClearFontErr
  1157.  
  1158. ' If SetMaxFonts hasn't been called then make sure the default is
  1159. ' correct:
  1160. flChkMax
  1161.  
  1162. ' Simply return the values of the internal variables for maximum
  1163. ' fonts registered and loaded:
  1164. Registered = FGP.MaxRegistered
  1165. Loaded = FGP.MaxLoaded
  1166.  
  1167. END SUB
  1168.  
  1169. '=== GetFontInfo - Returns useful information about current font
  1170. '
  1171. '  Arguments:
  1172. '     Font  -  Font number (in list of registered fonts) on which to get
  1173. '              information
  1174. '
  1175. '     FI    -  FontInfo type variable to receive info
  1176. '
  1177. '=================================================================
  1178. STATIC SUB GetRFontInfo (Font AS INTEGER, FI AS FontInfo)
  1179. SHARED FontHdrReg() AS IFontInfo
  1180.  
  1181. ON ERROR GOTO UnexpectedErr
  1182.  
  1183. ' Clear outstanding font errors:
  1184. flClearFontErr
  1185.  
  1186. ' See that they've specified a valid font:
  1187. IF Font < 0 OR Font > FGP.TotalRegistered THEN
  1188.     flSetFontErr cBadFontNumber
  1189.     EXIT SUB
  1190. END IF
  1191.  
  1192. ' All OK, assign values from internal font header:
  1193. FI.FontNum = Font
  1194. FI.Ascent = FontHdrReg(Font).FontHeader.dfAscent
  1195. FI.Points = FontHdrReg(Font).FontHeader.dfPoints
  1196. FI.PixWidth = FontHdrReg(Font).FontHeader.dfPixWidth
  1197. FI.PixHeight = FontHdrReg(Font).FontHeader.dfPixHeight
  1198. FI.Leading = FontHdrReg(Font).FontHeader.dfInternalLeading
  1199. FI.MaxWidth = FontHdrReg(Font).FontHeader.dfMaxWidth
  1200. FI.AvgWidth = FontHdrReg(Font).FontHeader.dfAvgWidth
  1201. FI.FileName = FontHdrReg(Font).FileName
  1202. FI.FaceName = FontHdrReg(Font).FaceName
  1203.  
  1204. END SUB
  1205.  
  1206. '=== GetTotalFonts - Gets the total number of fonts that currently registered
  1207. '                    and loaded by the font library:
  1208. '
  1209. '  Arguments:
  1210. '     Registered  -  The total number of fonts registered by the font
  1211. '                    library
  1212. '
  1213. '     Loaded      -  The total number of fonts loaded by the font library
  1214. '
  1215. '=================================================================
  1216. SUB GetTotalFonts (Registered AS INTEGER, Loaded AS INTEGER)
  1217. SHARED FGP AS GlobalParams
  1218.  
  1219. ON ERROR GOTO UnexpectedErr
  1220.  
  1221. ' Clear outstanding font errors:
  1222. flClearFontErr
  1223.  
  1224. ' Simply return the values of internal variables:
  1225. Registered = FGP.TotalRegistered
  1226. Loaded = FGP.TotalLoaded
  1227.  
  1228. END SUB
  1229.  
  1230. '=== GTextWindow - Communicates the current WINDOW to fontlib
  1231. '
  1232. '  Arguments:
  1233. '     X1    -  Minimum X value
  1234. '
  1235. '     Y1    -  Minimum Y value
  1236. '
  1237. '     X2    -  Maximum X value
  1238. '
  1239. '     Y2    -  Maximum Y value
  1240. '
  1241. '     Scrn% -  cTRUE means that window Y values increase top to bottom
  1242. '
  1243. '  Remarks:
  1244. '     Calling this with X1=X2 or Y1=Y2 will clear the current
  1245. '     window.
  1246. '
  1247. '=================================================================
  1248. SUB GTextWindow (X1 AS SINGLE, Y1 AS SINGLE, X2 AS SINGLE, Y2 AS SINGLE, Scrn%)
  1249. SHARED FGP AS GlobalParams
  1250.  
  1251. ON ERROR GOTO UnexpectedErr
  1252.  
  1253. ' Clear outstanding font errors:
  1254. flClearFontErr
  1255.  
  1256. ' Save the window values in global variable:
  1257. FGP.WX1 = X1
  1258. FGP.WY1 = Y1
  1259. FGP.WX2 = X2
  1260. FGP.WY2 = Y2
  1261. FGP.WScrn = Scrn%
  1262.  
  1263. ' If window is valid then flag it as set:
  1264. FGP.WindowSet = ((X2 - X1) <> 0) AND ((Y2 - Y1) <> 0)
  1265.  
  1266. END SUB
  1267.  
  1268. '=== LoadFont - Loads one or more fonts according to specification string
  1269. '
  1270. '  Arguments:
  1271. '     SpecTxt$ -  String containing parameters specifying one or more
  1272. '                 fonts to load (see notes below)
  1273. '
  1274. '  Return Values:
  1275. '     The number of fonts loaded
  1276. '
  1277. '  Notes:
  1278. '     A spec. can contain the following parameters in any order.
  1279. '     Parameters are each one character immediately followed by a value
  1280. '     if called for. Multiple specifications may be entered separated
  1281. '     by slash (/) characters. Loadfont will search for the FIRST font in
  1282. '     the list of registered fonts that matches each spec. and load it. If
  1283. '     no font matches a specification registered font number one will be
  1284. '     used. If a given font is selected by more than one spec in the list
  1285. '     it will only be loaded once. When this routine is called all
  1286. '     previous fonts will be discarded:
  1287. '
  1288. '        T  -  followed by a blank-terminated name loads font by
  1289. '              specified name
  1290. '
  1291. '        F  -  No value. Selects only fixed pitch fonts
  1292. '
  1293. '        P  -  No value. Selects only proportional fonts
  1294. '
  1295. '        S  -  Followed by number specifies desired point size
  1296. '
  1297. '        M  -  Followed by number specifies the screen mode font will be
  1298. '              used on. This is used in conjunction with the "S" parameter
  1299. '              above to select appropriately sized font.
  1300. '
  1301. '        H  -  Followed by number specifies the pixel height of
  1302. '              font to select. "S" overrides this.
  1303. '
  1304. '        N  -  Followed by number selects specific font number
  1305. '              from the list of currently registered fonts.
  1306. '
  1307. '        R  -  Selects font stored in RAM memory
  1308. '
  1309. '=================================================================
  1310. STATIC FUNCTION LoadFont% (SpecTxt$)
  1311. SHARED FGP AS GlobalParams
  1312. DIM FSpec AS FontSpec
  1313.  
  1314. ON ERROR GOTO UnexpectedErr
  1315.  
  1316. ' Clear outstanding errors and check for valid max limits:
  1317. flClearFontErr
  1318.  
  1319. flChkMax
  1320.  
  1321. ' Make sure there's room to load a font:
  1322. IF FGP.TotalLoaded >= FGP.MaxLoaded THEN
  1323.     flSetFontErr cTooManyFonts
  1324.     EXIT FUNCTION
  1325. END IF
  1326.  
  1327. ' Make sure there are some registered fonts to look through:
  1328. IF FGP.TotalRegistered <= 0 THEN
  1329.     flSetFontErr cNoFonts
  1330.     EXIT FUNCTION
  1331. END IF
  1332.  
  1333. ' Process each spec in the spec string:
  1334. Slot% = 1
  1335. ChPos% = 1
  1336. DO UNTIL Slot% > FGP.MaxLoaded
  1337.  
  1338.     ' Initialize the spec structure:
  1339.     flInitSpec FSpec
  1340.  
  1341.     ' Get next spec from string (Found will be false if no spec found):
  1342.     SpecStatus% = flGetNextSpec(SpecTxt$, ChPos%, FSpec)
  1343.     SELECT CASE SpecStatus%
  1344.         CASE 0:
  1345.         CASE 1: EXIT DO
  1346.         CASE 2: flSetFontErr cBadFontSpec
  1347.     END SELECT
  1348.  
  1349.     ' Try to match font. Set font to one if none match:
  1350.     FontNum% = flMatchFont(FSpec)
  1351.     IF FontNum% < 1 THEN
  1352.         flSetFontErr cFontNotFound
  1353.         FontNum% = 1
  1354.     END IF
  1355.  
  1356.     ' Record font in font load list:
  1357.     FontLoadList(Slot%) = FontNum%
  1358.     Slot% = Slot% + 1
  1359. LOOP
  1360.  
  1361. ' Now actually get the fonts in the load list:
  1362. FGP.TotalLoaded = flGetFonts(Slot% - 1)
  1363. FGP.CurrentFont = 1
  1364.  
  1365. ' Select the first font by default (pass outstanding font errors around
  1366. ' it):
  1367. HoldErr% = FontErr
  1368. SelectFont cDefaultFont
  1369. IF HoldErr% <> 0 THEN flSetFontErr HoldErr%
  1370.  
  1371. LoadFont = FGP.TotalLoaded
  1372.  
  1373. END FUNCTION
  1374.  
  1375. '=== OutGText - Outputs graphics text to the screen
  1376. '
  1377. '  Arguments:
  1378. '     X        -  X location of upper left of char box
  1379. '
  1380. '     Y        -  Y location of upper left of char box
  1381. '
  1382. '     Text$    -  Text string to output
  1383. '
  1384. '  Return Values:
  1385. '     Length of text output, Values of X and Y are updated
  1386. '
  1387. '=================================================================
  1388. STATIC FUNCTION OutGText% (X AS SINGLE, Y AS SINGLE, Text$)
  1389. SHARED FGP AS GlobalParams
  1390. SHARED FontHdrLoaded() AS IFontInfo
  1391.  
  1392. ON ERROR GOTO UnexpectedErr
  1393.  
  1394. ' Clear outstanding font errors:
  1395. flClearFontErr
  1396.  
  1397. ' Make sure fonts are loaded:
  1398. IF FGP.TotalLoaded <= 0 THEN
  1399.     flSetFontErr cNoFonts
  1400.     EXIT FUNCTION
  1401. END IF
  1402.  
  1403. IF NOT FGP.CharColorInit THEN SetGTextColor cDefaultColor
  1404. IF NOT FGP.CharDirInit THEN SetGTextDir cDefaultDir
  1405.  
  1406. ' Make sure a graphic mode is set:
  1407. flGetCurrentScrnSize XP%, YP%
  1408. IF XP% = 0 THEN EXIT FUNCTION
  1409.  
  1410. ' Save input location to working variables and erase any window setting:
  1411. IX% = PMAP(X, 0)
  1412. IY% = PMAP(Y, 1)
  1413. WINDOW
  1414.  
  1415. ' Map chars to valid ones and output them adding their lengths:
  1416. TextLen% = 0
  1417. FOR Char% = 1 TO LEN(Text$)
  1418.     ChVal% = ASC(MID$(Text$, Char%, 1))
  1419.     IF FGP.CharSet = cIBMChars THEN ChVal% = flANSI(ChVal%)
  1420.   
  1421.     IF FGP.FontSource = cFileFont THEN
  1422.         BitMapPtr% = VARPTR(FontData(FGP.DSeg))
  1423.         BitMapSeg% = VARSEG(FontData(FGP.DSeg))
  1424.     ELSE
  1425.         BitMapPtr% = FGP.DOffset
  1426.         BitMapSeg% = FGP.DSeg
  1427.     END IF
  1428.  
  1429.     CharLen% = flbltchar%(BitMapSeg%, BitMapPtr%, ChVal%, IX%, IY%)
  1430.  
  1431.     IX% = IX% + FGP.XPixInc * CharLen%
  1432.     IY% = IY% + FGP.YPixInc * CharLen%
  1433.  
  1434.     TextLen% = TextLen% + CharLen%
  1435. NEXT Char%
  1436.  
  1437. ' Reset window:
  1438. IF FGP.WindowSet THEN
  1439.     IF FGP.WScrn% THEN
  1440.         WINDOW SCREEN (FGP.WX1, FGP.WY1)-(FGP.WX2, FGP.WY2)
  1441.     ELSE
  1442.         WINDOW (FGP.WX1, FGP.WY1)-(FGP.WX2, FGP.WY2)
  1443.     END IF
  1444. END IF
  1445.  
  1446. ' Update locations
  1447. X = PMAP(IX%, 2)
  1448. Y = PMAP(IY%, 3)
  1449.  
  1450. ' Return total character length:
  1451. OutGText = TextLen%
  1452.  
  1453. END FUNCTION
  1454.  
  1455. '=== RegisterFonts - Loads header information from font resources:
  1456. '
  1457. '  Arguments:
  1458. '     FileName$   -  Path name for font file to register
  1459. '
  1460. '  Return Value:
  1461. '     The number of fonts actually registered
  1462. '
  1463. '  Notes:
  1464. '     Offsets documented in Windows document assume the file's first
  1465. '     byte is byte 0 (zero) and GET assumes the first byte is byte 1 so
  1466. '     many GET locations are expressed in the following code as
  1467. '     a documented offset + 1.
  1468. '
  1469. '=================================================================
  1470. STATIC FUNCTION RegisterFonts% (FileName$)
  1471. SHARED FGP AS GlobalParams
  1472. DIM Byte AS STRING * 1
  1473.  
  1474. ON ERROR GOTO UnexpectedErr
  1475.  
  1476. ' Clear errors and make sure things are initialized:
  1477. flClearFontErr
  1478.  
  1479. flChkMax
  1480.  
  1481. ' Get next available file number:
  1482. FileNum% = FREEFILE
  1483.  
  1484. ' Try to open the file for input first to make sure the file exists. This
  1485. ' is done to avoid creating a zero length file if the file doesn't exist.
  1486. ON ERROR GOTO NoFileErr
  1487. OPEN FileName$ FOR INPUT AS FileNum%
  1488. ON ERROR GOTO UnexpectedErr
  1489. IF FontErr <> 0 THEN
  1490.     RegisterFonts = 0
  1491.     EXIT FUNCTION
  1492. END IF
  1493. CLOSE FileNum%
  1494.  
  1495. ' File seems to exist, so open it in binary mode:
  1496. OPEN FileName$ FOR BINARY ACCESS READ AS FileNum%
  1497.  
  1498. ' Get the byte that indicates whether this file has a new-style
  1499. ' header on it. If not, then error:
  1500. GET FileNum%, &H18 + 1, Byte
  1501. IF ASC(Byte) <> &H40 THEN
  1502.     flSetFontErr cBadFontFile
  1503.     CLOSE FileNum%
  1504.     EXIT FUNCTION
  1505. END IF
  1506.  
  1507. ' Save the number of fonts currently registered for use later in
  1508. ' calculating the number of fonts registered by this call:
  1509. OldTotal = FGP.TotalRegistered
  1510.  
  1511. ' Get the pointer to the new-style header:
  1512. GET FileNum%, &H3C + 1, Word%
  1513. NewHdr% = Word%
  1514.  
  1515. ' Get pointer to resource table:
  1516. GET FileNum%, Word% + &H22 + 1, Word%
  1517. ResourceEntry# = NewHdr% + Word% + 1
  1518.  
  1519. ' Get the alignment shift count from beginning of table:
  1520. GET FileNum%, ResourceEntry#, Align%
  1521.  
  1522. ' Loop, registering font resources until they have run out:
  1523. DO
  1524.     ResType% = flDoNextResource(Align%, FileName$, FileNum%)
  1525.     IF FontErr <> 0 THEN EXIT DO
  1526. LOOP UNTIL ResType% = 0
  1527.  
  1528. CLOSE FileNum%
  1529.  
  1530. ' Finally, return number of fonts actually registered:
  1531. RegisterFonts = FGP.TotalRegistered - OldTotal
  1532.  
  1533. END FUNCTION
  1534.  
  1535. '=== RegisterMemFont - Loads header information from a memory-resident font
  1536. '
  1537. '  Arguments:
  1538. '     FontSeg%    -  Segment address of font to register
  1539. '
  1540. '     FontOffset% -  Offset address of font to register
  1541. '
  1542. '  Return Value:
  1543. '     The number of fonts actually registered (0 or 1)
  1544. '
  1545. '  Notes:
  1546. '     Memory resident fonts cannot be stored in BASIC relocatable data
  1547. '     structures (like arrays or non-fixed strings).
  1548. '
  1549. '=================================================================
  1550. STATIC FUNCTION RegisterMemFont% (FontSeg AS INTEGER, FontOffset AS INTEGER)
  1551. SHARED FGP AS GlobalParams
  1552. SHARED FontHdrReg() AS IFontInfo
  1553. DIM FontHeader AS WFHeader
  1554.  
  1555. ON ERROR GOTO UnexpectedErr
  1556.  
  1557. ' Clear error and check max limits:
  1558. flClearFontErr
  1559. flChkMax
  1560.  
  1561. ' Get the font header:
  1562. flMovMem FontHeader, FontSeg, FontOffset, cSizeFontHeader
  1563.  
  1564. ' Only register vector fonts:
  1565. IF FontHeader.dfType AND &H1 <> cBitMapType THEN
  1566.     flSetFontErr cBadFontType
  1567.     RegisterMemFont = 0
  1568.     EXIT FUNCTION
  1569. END IF
  1570.  
  1571. ' See that we're still within MaxRegistered limits:
  1572. IF FGP.TotalRegistered >= FGP.MaxRegistered THEN
  1573.     flSetFontErr cTooManyFonts
  1574.     RegisterMemFont = 0
  1575.     EXIT FUNCTION
  1576. END IF
  1577.  
  1578. ' Go to next "registered" font slot:
  1579. FGP.TotalRegistered = FGP.TotalRegistered + 1
  1580.  
  1581. ' Set font source and save the header:
  1582. FontHdrReg(FGP.TotalRegistered).FontSource = cMemFont
  1583. FontHdrReg(FGP.TotalRegistered).FontHeader = FontHeader
  1584.  
  1585. ' Set font location in memory:
  1586. FontHdrReg(FGP.TotalRegistered).DataSeg = FontSeg
  1587. FontHdrReg(FGP.TotalRegistered).DataOffset = FontOffset + cSizeFontHeader
  1588.  
  1589. ' Get the face name (scan characters until zero byte):
  1590. FaceLoc% = FontOffset + FontHeader.dfFace
  1591. FaceName$ = ""
  1592. DEF SEG = FontSeg
  1593. FOR Char% = 0 TO cMaxFaceName - 1
  1594.     Byte% = PEEK(FaceLoc% + Char%)
  1595.     IF Byte% = 0 THEN EXIT FOR
  1596.     FaceName$ = FaceName$ + CHR$(Byte%)
  1597. NEXT Char%
  1598. FontHdrReg(FGP.TotalRegistered).FaceName = FaceName$
  1599.  
  1600. ' Finally, return number of fonts actually registered:
  1601. RegisterMemFont = 1
  1602.  
  1603. END FUNCTION
  1604.  
  1605. '=== SelectFont - Selects current font from among loaded fonts
  1606. '
  1607. '  Arguments:
  1608. '     FontNum% -  Font number to select
  1609. '
  1610. '=================================================================
  1611. STATIC SUB SelectFont (FontNum AS INTEGER)
  1612. SHARED FGP AS GlobalParams
  1613.  
  1614. ON ERROR GOTO UnexpectedErr
  1615.  
  1616. ' Clear outstanding font errors:
  1617. flClearFontErr
  1618.  
  1619. ' If no fonts are loaded then error:
  1620. IF FGP.TotalLoaded <= 0 THEN
  1621.     flSetFontErr cNoFonts
  1622.     EXIT SUB
  1623. END IF
  1624.  
  1625. ' Now, map the font number to an acceptable one and select it:
  1626. IF FontNum <= 0 THEN
  1627.     FGP.CurrentFont = 1
  1628. ELSE
  1629.     FGP.CurrentFont = (ABS(FontNum - 1) MOD (FGP.TotalLoaded)) + 1
  1630. END IF
  1631.  
  1632. ' Get First, Last and Default character params from header:
  1633. FGP.FChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfFirstChar)
  1634. FGP.LChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfLastChar)
  1635. FGP.DChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfDefaultChar)
  1636. FGP.CHeight = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixHeight
  1637. flSetBltParams cSizeFontHeader, FGP.CHeight, FGP.FChar, FGP.LChar, FGP.DChar
  1638.  
  1639. ' Set some other commonly used elements of font info:
  1640. FGP.DSeg = FontHdrLoaded(FGP.CurrentFont).DataSeg
  1641. FGP.DOffset = FontHdrLoaded(FGP.CurrentFont).DataOffset
  1642. FGP.FontSource = FontHdrLoaded(FGP.CurrentFont).FontSource
  1643.  
  1644. END SUB
  1645.  
  1646. '=== SetGCharset - Specifies IBM or Windows char set
  1647. '
  1648. '  Arguments:
  1649. '     Charset%    -  cIBMChars for IBM character mappings
  1650. '                    cWindowsChars for Windows character mappings
  1651. '
  1652. '=================================================================
  1653. STATIC SUB SetGCharset (CharSet AS INTEGER)
  1654. SHARED FGP AS GlobalParams
  1655.  
  1656. ON ERROR GOTO UnexpectedErr
  1657.  
  1658. ' Clear outstanding font errors:
  1659. flClearFontErr
  1660.  
  1661. IF CharSet = cWindowsChars THEN
  1662.     FGP.CharSet = cWindowsChars
  1663. ELSE
  1664.     FGP.CharSet = cIBMChars
  1665. END IF
  1666.  
  1667. END SUB
  1668.  
  1669. '=== SetGTextColor - Sets color for drawing characters
  1670. '
  1671. '  Arguments:
  1672. '     FColor   -  Color number
  1673. '
  1674. '=================================================================
  1675. STATIC SUB SetGTextColor (FColor AS INTEGER)
  1676. SHARED FGP AS GlobalParams
  1677.  
  1678. ON ERROR GOTO UnexpectedErr
  1679.  
  1680. ' Clear outstanding font errors:
  1681. flClearFontErr
  1682.   
  1683. FGP.CharColor = ABS(FColor)
  1684. flSetBltColor FGP.CharColor
  1685. FGP.CharColorInit = cTRUE
  1686.  
  1687. END SUB
  1688.  
  1689. '=== SetGTextDir - Sets character direction for OutGText
  1690. '
  1691. '  Arguments:
  1692. '     Dir   -  Character direction:
  1693. '              0 = Horizontal-Right
  1694. '              1 = Vertical-Up
  1695. '              2 = Horizontal-Left
  1696. '              3 = Vertical-Down
  1697. '
  1698. '=================================================================
  1699. STATIC SUB SetGTextDir (Dir AS INTEGER)
  1700. SHARED FGP AS GlobalParams
  1701.  
  1702. ON ERROR GOTO UnexpectedErr
  1703.  
  1704. ' Clear outstanding font errors:
  1705. flClearFontErr
  1706.  
  1707. SELECT CASE Dir
  1708.  
  1709.     ' Vertical - up
  1710.     CASE 1:  FGP.XPixInc% = 0
  1711.                 FGP.YPixInc% = -1
  1712.                 XRowInc% = 1
  1713.                 YRowInc% = 0
  1714.                 FGP.CharDir = 1
  1715.   
  1716.     ' Horizontal -left
  1717.     CASE 2:  FGP.XPixInc% = -1
  1718.                 FGP.YPixInc% = 0
  1719.                 XRowInc% = 0
  1720.                 YRowInc% = -1
  1721.                 FGP.CharDir = 2
  1722.   
  1723.     ' Vertical - down
  1724.     CASE 3:  FGP.XPixInc% = 0
  1725.                 FGP.YPixInc% = 1
  1726.                 XRowInc% = -1
  1727.                 YRowInc% = 0
  1728.                 FGP.CharDir = 3
  1729.   
  1730.     ' Horizontal - right
  1731.     CASE ELSE:  FGP.XPixInc% = 1
  1732.                     FGP.YPixInc% = 0
  1733.                     XRowInc% = 0
  1734.                     YRowInc% = 1
  1735.                     FGP.CharDir = 0
  1736.     END SELECT
  1737.  
  1738.     ' Call routine to set these increments in the char output routine
  1739.     flSetBltDir FGP.XPixInc%, FGP.YPixInc%, XRowInc%, YRowInc%
  1740.     FGP.CharDirInit = cTRUE
  1741.  
  1742. END SUB
  1743.  
  1744. '=== SetMaxFonts - Sets the maximum number of fonts that can be registered
  1745. '                  and loaded by the font library:
  1746. '
  1747. '  Arguments:
  1748. '     Registered  -  The maximum number of fonts that can be registered
  1749. '                    by the font library
  1750. '
  1751. '     Loaded      -  The maximum number of fonts that can be loaded by
  1752. '                    by the font library
  1753. '
  1754. '  Return Values:
  1755. '     Sets error if values are not positive. Adjusts MaxReg and MaxLoad
  1756. '     internal values and resets the length of FontHdrReg and FontHdrLoad
  1757. '     arrays if the new value is different from previous one
  1758. '
  1759. '=================================================================
  1760. STATIC SUB SetMaxFonts (Registered AS INTEGER, Loaded AS INTEGER)
  1761. SHARED FGP AS GlobalParams
  1762. SHARED FontHdrReg() AS IFontInfo
  1763. SHARED FontHdrLoaded() AS IFontInfo
  1764. SHARED FontLoadList() AS INTEGER
  1765. SHARED FontData() AS FontDataBlock
  1766.  
  1767. ON ERROR GOTO UnexpectedErr
  1768.  
  1769. ' Clear errors:
  1770. flClearFontErr
  1771.  
  1772. ' Check to see that values are within range:
  1773. IF Registered <= 0 OR Loaded <= 0 THEN
  1774.     flSetFontErr cBadFontLimit
  1775.     EXIT SUB
  1776. END IF
  1777.  
  1778. ' Values are ostensibly OK. Reset values and redimension arrays:
  1779. ' Reset values for registered fonts:
  1780. FGP.TotalRegistered = 0
  1781. FGP.MaxRegistered = Registered
  1782.   
  1783. ON ERROR GOTO MemErr
  1784. REDIM FontHdrReg(1 TO FGP.MaxRegistered) AS IFontInfo
  1785. ON ERROR GOTO UnexpectedErr
  1786.  
  1787. ' Reset values for loaded fonts:
  1788. FGP.TotalLoaded = 0
  1789. FGP.MaxLoaded = Loaded
  1790.   
  1791. ON ERROR GOTO MemErr
  1792. REDIM FontLoadList(1 TO FGP.MaxLoaded) AS INTEGER
  1793. REDIM FontHdrLoaded(1 TO FGP.MaxLoaded) AS IFontInfo
  1794. ON ERROR GOTO UnexpectedErr
  1795.  
  1796. ' Clear font data array:
  1797. ERASE FontData
  1798.  
  1799. END SUB
  1800.  
  1801. '=== UnRegisterFonts - Erases registered font header array and resets
  1802. '                      total registered fonts to 0:
  1803. '
  1804. '  Arguments:
  1805. '     ErrNum   -  The error number to set FontErr variable to
  1806. '
  1807. '=================================================================
  1808. STATIC SUB UnRegisterFonts ()
  1809. SHARED FontHdrReg() AS IFontInfo, FGP AS GlobalParams
  1810.  
  1811. ON ERROR GOTO UnexpectedErr
  1812.  
  1813. ' Clear outstanding font errors:
  1814. flClearFontErr
  1815.  
  1816. REDIM FontHdrReg(1 TO 1)  AS IFontInfo
  1817. FGP.MaxRegistered = UBOUND(FontHdrReg, 1)
  1818. FGP.TotalRegistered = 0
  1819.  
  1820. END SUB
  1821.  
  1822.