home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l196 / 3.ddi / FONTDEMO.BA$ / FONTDEMO.bin
Encoding:
Text File  |  1990-06-24  |  9.4 KB  |  358 lines
  1. '       FONTDEMO.BAS - FONTB demonstration program.
  2. '
  3. '  Copyright (C) 1989-1990 Microsoft Corporation, All Rights Reserved
  4. '
  5. '  This program demonstrates some of the capabilities of the fonts
  6. '  toolbox.  It loads font files found in the current directory and
  7. '  and allows you to select a font for display.
  8. '
  9. '  The following font files are provided with BASIC 7.1:
  10. '     - Raster fonts designed for screen resolution of 640x200
  11. '           COURA.FON
  12. '           HELVA.FON
  13. '           TMSRA.FON
  14. '     - Raster fonts designed for screen resolution of 640x350
  15. '           COURB.FON
  16. '           HELVB.FON
  17. '           TMSRB.FON
  18. '     - Raster fonts designed for screen resolution of 640x480
  19. '           COURE.FON
  20. '           HELVE.FON
  21. '           TMSRE.FON
  22. '
  23. ' $INCLUDE: 'FONTB.BI'
  24. CONST TRUE = -1
  25. CONST FALSE = 0
  26. DECLARE SUB DriveScreen ()
  27. DECLARE SUB GetFiles ()
  28. DECLARE SUB GetModes ()
  29. DECLARE SUB ShowScreen ()
  30.  
  31. DIM SHARED FI AS FontInfo
  32. DIM SHARED totalmodes AS INTEGER
  33. DIM SHARED modes(1 TO 13) AS INTEGER
  34. DIM SHARED fontfiles(1 TO 18) AS STRING
  35. DIM SHARED totalfonts AS INTEGER
  36. DIM SHARED currentfont AS INTEGER
  37. DIM SHARED currentmode AS INTEGER
  38. GetModes
  39. GetFiles
  40. currentfont = 1
  41. DO
  42.     DriveScreen
  43.     ShowScreen
  44. LOOP
  45. END
  46.  
  47. '
  48. 'DriveScreen displays the lists of available fonts and screen modes and
  49. 'scrolls through them with arrow keys.
  50. '
  51. SUB DriveScreen STATIC
  52. IF init% = 0 THEN
  53.     set$ = "f"
  54.     max% = totalfonts
  55.     posit% = currentfont
  56.     modedim$ = "320x200640x200720x348640x400              320x200"
  57.     modedim$ = modedim$ + "640x200640x350640x350640x480640x480320x200"
  58.  
  59.     'Check if monitor supports color or mono.
  60.  
  61.     SELECT CASE modes(1)
  62.         CASE 13, 9, 8, 7
  63.             mode$ = "color"
  64.         CASE 3, 4, 10
  65.             mode$ = "mono"
  66.         CASE 2
  67.             IF modes(2) = 1 THEN
  68.                 mode$ = "color"
  69.             ELSE
  70.                 mode$ = "mono"
  71.             END IF
  72.     END SELECT
  73.     FOR i% = 1 TO totalmodes
  74.         IF modes(i%) = 4 THEN mode$ = "mono"
  75.     NEXT i%
  76.  
  77.     'Set colors based on type of monitor.
  78.  
  79.     SELECT CASE mode$
  80.         CASE "color"
  81.             listfore% = 7
  82.             listback% = 0
  83.             titleon% = 15
  84.             titleoff% = 7
  85.             titleback% = 1
  86.             back% = 1
  87.             high% = 15
  88.         CASE "mono"
  89.             listfore% = 7
  90.             listback% = 0
  91.             titleon% = 0
  92.             titleoff% = 2
  93.             titleback% = 7
  94.             back% = 0
  95.             high% = 7
  96.     END SELECT
  97.     init% = 1
  98. END IF
  99.  
  100. 'Display the screen with the current selections.
  101.  
  102. SCREEN 0
  103. WIDTH 80, 25
  104. LOCATE , , 0: COLOR 0, back%
  105. PRINT SPACE$(1920)
  106. LOCATE 2, 1: COLOR high%, back%
  107. PRINT "  Font Toolbox Demo"
  108. COLOR titleoff%, back%
  109. PRINT "  Copyright (C) 1989-1990 Microsoft Corporation"
  110. LOCATE 22, 1: COLOR titleoff%, back%
  111. PRINT SPC(55); "<CR> to view fontfile"
  112. PRINT SPC(55); "ESC to exit"
  113.  
  114. GOSUB swaptitles
  115. GOSUB swaptitles
  116. FOR i% = 1 TO totalfonts
  117.     LOCATE 5 + i%, 20
  118.     COLOR listfore%, listback%
  119.     PRINT LEFT$(fontfiles(i%) + "       ", 12)
  120. NEXT i%
  121. LOCATE 5 + currentfont, 20
  122. COLOR listback%, listfore%
  123. PRINT LEFT$(fontfiles(currentfont) + "       ", 12)
  124.  
  125. FOR i% = 1 TO totalmodes
  126.     LOCATE 5 + i%, 50
  127.     COLOR listfore%, listback%
  128.     PRINT LEFT$(STR$(modes(i%)) + "   ", 4) + MID$(modedim$, 7 * modes(i%) - 6, 7)
  129. NEXT i%
  130. LOCATE 5 + currentmode, 50
  131. COLOR listback%, listfore%
  132. PRINT LEFT$(STR$(modes(currentmode)) + "   ", 4) + MID$(modedim$, 7 * modes(currentmode) - 6, 7)
  133.  
  134. 'Scroll through choices
  135.  
  136. DO
  137.     SELECT CASE INKEY$
  138.         CASE CHR$(0) + CHR$(72)
  139.             GOSUB upone
  140.         CASE CHR$(0) + CHR$(80)
  141.             GOSUB downone
  142.         CASE CHR$(9), CHR$(0) + CHR$(15), CHR$(0) + CHR$(75), CHR$(0) + CHR$(77)
  143.             GOSUB swaptitles
  144.         CASE CHR$(13), CHR$(32): EXIT DO
  145.         CASE CHR$(27)
  146.           COLOR 15, 0
  147.           CLS
  148.           END
  149.     END SELECT
  150. LOOP
  151. EXIT SUB
  152.  
  153. swaptitles:
  154.     IF set$ = "f" THEN
  155.         set$ = "m"
  156.         max% = totalmodes
  157.         posit% = currentmode
  158.         LOCATE 5, 20: COLOR titleoff%, back%
  159.         PRINT "Font files:"
  160.         LOCATE 5, 50: COLOR titleon%, titleback%
  161.         PRINT "Screen Modes:"
  162.     ELSEIF set$ = "m" THEN
  163.         set$ = "f"
  164.         max% = totalfonts
  165.         posit% = currentfont
  166.         LOCATE 5, 20: COLOR titleon%, titleback%
  167.         PRINT "Font files:"
  168.         LOCATE 5, 50: COLOR titleoff%, back%
  169.         PRINT "Screen Modes:"
  170.     END IF
  171. RETURN
  172.  
  173. upone:
  174.     oldpos% = posit%
  175.     posit% = (posit% + max% - 2) MOD max% + 1
  176.     GOSUB redraw
  177. RETURN
  178.  
  179. downone:
  180.     oldpos% = posit%
  181.     posit% = posit% MOD max% + 1
  182.     GOSUB redraw
  183. RETURN
  184.  
  185. redraw:
  186.     IF set$ = "f" THEN
  187.         LOCATE 5 + oldpos%, 20
  188.         COLOR listfore%, listback%
  189.         PRINT LEFT$(fontfiles(oldpos%) + "       ", 12)
  190.         LOCATE 5 + posit%, 20
  191.         COLOR listback%, listfore%
  192.         PRINT LEFT$(fontfiles(posit%) + "       ", 12)
  193.         currentfont = posit%
  194.     ELSE
  195.         LOCATE 5 + oldpos%, 50
  196.         COLOR listfore%, listback%
  197.         PRINT LEFT$(STR$(modes(oldpos%)) + "   ", 4) + MID$(modedim$, 7 * modes(oldpos%) - 6, 7)
  198.         LOCATE 5 + posit%, 50
  199.         COLOR listback%, listfore%
  200.         PRINT LEFT$(STR$(modes(posit%)) + "   ", 4) + MID$(modedim$, 7 * modes(posit%) - 6, 7)
  201.         currentmode = posit%
  202.     END IF
  203. RETURN
  204.  
  205. END SUB
  206.  
  207. '
  208. 'GetFiles finds all *.fon files in the current working directory and checks
  209. 'if they are legitimate.  If the files are ok, they are added to files list.
  210. '
  211. SUB GetFiles
  212. SCREEN 0
  213. WIDTH 80, 25
  214. tryagain:
  215. CLS
  216. PRINT "Checking fontfiles..."
  217. totalfonts = 0
  218. X$ = DIR$("*.fon")
  219. IF X$ = "" THEN
  220.     PRINT "No font files found in current directory."
  221.     PRINT "Push a shell to change directories? [yn]"
  222.     try$ = "a"
  223.     DO UNTIL INSTR(1, "NYny", try$)
  224.         try$ = INPUT$(1)
  225.     LOOP
  226.     SELECT CASE UCASE$(try$)
  227.         CASE "Y"
  228.             PRINT "Type 'EXIT' to return to demo."
  229.             SHELL
  230.             GOTO tryagain
  231.         CASE "N"
  232.             END
  233.     END SELECT
  234. ELSE
  235.     DO WHILE X$ <> ""
  236.         PRINT "   "; UCASE$(X$); "--";
  237.         SetMaxFonts 10, 10
  238.         Reg% = RegisterFonts(X$)
  239.         IF Reg% = 0 THEN
  240.             PRINT "bad font file"
  241.         ELSE
  242.             totalfonts = totalfonts + 1
  243.             fontfiles(totalfonts) = UCASE$(X$)
  244.             PRINT "OK"
  245.             IF totalfonts = 18 THEN EXIT DO
  246.         END IF
  247.         X$ = DIR$
  248.     LOOP
  249. END IF
  250. SLEEP 1
  251. END SUB
  252.  
  253. '
  254. 'GetModes tries all screen modes from 1-13 to see if they are supported.
  255. 'If a mode is supported, it is added to the list of available modes.
  256. '
  257. SUB GetModes
  258. ON LOCAL ERROR GOTO badmode
  259. nextactive% = 1
  260. totalmodes = 0
  261. FOR i% = 13 TO 1 STEP -1
  262.     good% = TRUE
  263.     SCREEN i%
  264.     IF good% THEN
  265.         modes(nextactive%) = i%
  266.         nextactive% = nextactive% + 1
  267.         totalmodes = totalmodes + 1
  268.     END IF
  269. NEXT i%
  270. IF totalmodes = 0 THEN
  271.     PRINT "No graphics modes available"
  272.     END
  273. END IF
  274.  
  275. IF modes(1) = 13 THEN
  276.     currentmode = 2
  277. ELSE
  278.     currentmode = 1
  279. END IF
  280. EXIT SUB
  281. badmode:
  282.     good% = FALSE
  283.     RESUME NEXT
  284. END SUB
  285.  
  286. '
  287. 'ShowScreen displays all the fonts in the current font file and current
  288. 'graphics mode.
  289. '
  290. SUB ShowScreen
  291.     SetMaxFonts 10, 10
  292.     TotalReg% = RegisterFonts(fontfiles(currentfont))
  293.     SCREEN modes(currentmode)
  294.     PRINT "Please wait..."
  295.  
  296.     IF FontErr THEN
  297.         CLS
  298.         PRINT "Unable to continue, FontErr ="; FontErr
  299.         C$ = INPUT$(1)
  300.         EXIT SUB
  301.     END IF
  302.     IF TotalReg% > 10 THEN TotalReg% = 10
  303.  
  304.     StrLen% = TotalReg% * 3 - 1
  305.     IF TotalReg% > 9 THEN StrLen% = StrLen% + TotalReg% - 9
  306.     LoadStr$ = LEFT$("N1/N2/N3/N4/N5/N6/N7/N8/N9/N10", StrLen%)
  307.     TotalLoad% = LoadFont(LoadStr$)
  308.  
  309.     SELECT CASE modes(currentmode)
  310.         CASE 1: XS% = 160: YS% = 100
  311.         CASE 2: XS% = 320: YS% = 100
  312.         CASE 3: XS% = 360: YS% = 174
  313.         CASE 4: XS% = 320: YS% = 200
  314.         CASE 7: XS% = 160: YS% = 100
  315.         CASE 8: XS% = 320: YS% = 100
  316.         CASE 9: XS% = 320: YS% = 175
  317.         CASE 10: XS% = 320: YS% = 175
  318.         CASE 11: XS% = 320: YS% = 240
  319.         CASE 12: XS% = 320: YS% = 240
  320.         CASE 13: XS% = 160: YS% = 100
  321.     END SELECT
  322.  
  323.     prompt$ = "Press any key."
  324.     FOR i% = 1 TO TotalLoad%
  325.         CLS
  326.         SelectFont INT(i%)
  327.         GetFontInfo FI
  328.         SetGTextDir 0
  329.         SetGTextColor 14
  330.         Length% = OutGText(1, 1, RTRIM$(FI.FaceName))
  331.         Length% = OutGText(1, 1 + FI.PixHeight, LTRIM$(STR$(FI.Points) + " Point"))
  332.         FOR Dir% = 0 TO 3
  333.             SetGTextDir Dir%
  334.             SetGTextColor 15 - Dir%
  335.             SELECT CASE Dir%
  336.                 CASE 0: X% = XS%: Y% = YS% - FI.PixHeight
  337.                 CASE 1: X% = XS% - FI.PixHeight: Y% = YS%
  338.                 CASE 2: X% = XS%: Y% = YS% + FI.PixHeight
  339.                 CASE 3: X% = XS% + FI.PixHeight: Y% = YS%
  340.             END SELECT
  341.             Length% = OutGText(CSNG(X%), CSNG(Y%), "Microsoft")
  342.         NEXT Dir%
  343.         SelectFont 2
  344.         GetFontInfo FI
  345.         SetGTextColor 14
  346.         SetGTextDir 0
  347.         IF i% = TotalLoad% THEN prompt$ = "Press ESC to go on."
  348.         Length% = GetGTextLen(prompt$)
  349.         Length% = OutGText(2 * XS% - Length% - 10, 2 * YS% - FI.PixHeight - 1, prompt$)
  350.         IF i% = TotalLoad% THEN
  351.             DO UNTIL INKEY$ = CHR$(27): LOOP
  352.         ELSE
  353.             a$ = INPUT$(1)
  354.         END IF
  355.     NEXT i%
  356. END SUB
  357.  
  358.