home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / BASIC / IMB9003.ZIP / FONTSCR.BAS < prev    next >
Encoding:
BASIC Source File  |  1990-03-01  |  6.1 KB  |  203 lines
  1. ' $INCLUDE: 'E:\bc7\bin\t90feb\tFONTS\FontScr.BI'
  2.  
  3. DIM SHARED CS AS CurrentSetUp
  4. DIM SHARED FI AS FontInfo
  5. DIM SHARED Totalfonts AS INTEGER
  6. DIM SHARED CurrentFont AS INTEGER
  7. DIM SHARED CurrentMode AS INTEGER
  8.  
  9. FUNCTION CalcGPos% (GLine%, GCol%, VPos, HPos)
  10.    VPos = GLine% * FI.PixHeight - FI.PixHeight
  11.    HPos = GCol% * FI.AvgWidth - FI.AvgWidth
  12.    IF VPos > CS.YMax OR VPos < 0 OR HPos > CS.XMax OR HPos < 0 THEN
  13.       CalcGPos% = False
  14.    ELSE
  15.       CalcGPos% = True
  16.    END IF
  17. END FUNCTION
  18.  
  19. FUNCTION GCentered% (GLine%, Text$)
  20.    GCol% = 1
  21.    Res% = CalcGPos%(GLine%, GCol%, VPos, HPos)
  22.    PPos% = (CS.XMax - GetGTextLen%(Text$)) \ 2
  23.    IF PPos% >= 0 THEN
  24.       PLen% = OutGText%(CSNG(PPos%), VPos, Text$)
  25.    END IF
  26.    GCentered% = PPos%
  27. END FUNCTION
  28.  
  29. FUNCTION GInput$ (GLine%, GCol%, GLen%)
  30.    GPos% = GCol%
  31.  
  32.    CR$ = CHR$(13): Tab$ = CHR$(9): Esc$ = CHR$(27)
  33.    TestStr$ = CR$ + Tab$ + Esc$
  34.    CurRefresh% = 300: CurCtr% = 0
  35.    SetCOff% = False: CurOff% = True    'Initialize cursor
  36.    DO
  37.       GOSUB DoCursor
  38.       a$ = INKEY$
  39.       EndChr% = (LEN(a$) * INSTR(TestStr$, a$)) > 0 'Mult then cmp because of instr null match
  40.       IF a$ <> "" AND NOT EndChr% THEN
  41.          SetCOff% = True
  42.          GOSUB DoCursor
  43.          IF a$ = CHR$(8) THEN
  44.             IF LEN(Istr$) > 0 THEN
  45.                Istr$ = LEFT$(Istr$, LEN(Istr$) - 1)
  46.                GPos% = GPos% - 1
  47.                Res% = GSpace(GLine%, GPos%, CS.BGColor%)
  48.             END IF
  49.          ELSE
  50.             SetGTextColor CS.FGColor%
  51.             Istr$ = Istr$ + a$
  52.             Res% = GPLine%(GLine%, GPos%, a$)
  53.             GPos% = GPos% + 1
  54.          END IF
  55.          SetCOff% = False
  56.       END IF
  57.    LOOP UNTIL EndChr% OR LEN(Istr$) = GLen%
  58.    SetCOff% = True
  59.    GOSUB DoCursor
  60.    GInput$ = Istr$
  61.    COLOR CS.FGColor%
  62.    EXIT FUNCTION
  63.  
  64. DoCursor:
  65.  
  66.    CurCtr% = CurCtr% + 1
  67.    Refreshing% = CurCtr% > CurRefresh%
  68.    IF (Refreshing% AND NOT CurOff%) OR SetCOff% THEN  'Turn the cursor off
  69.       Res% = CalcGPos%(GLine%, GPos%, VPos, HPos)
  70.       COLOR CS.BGColor
  71.       LINE (HPos, VPos)-(HPos, VPos + FI.PixHeight)
  72.       CurOff% = True
  73.    ELSEIF (Refreshing% AND CurOff%) THEN              'Turn the cursor on
  74.       Res% = CalcGPos%(GLine%, GPos%, VPos, HPos)
  75.       COLOR CS.FGColor
  76.       LINE (HPos, VPos)-(HPos, VPos + FI.PixHeight)
  77.       CurOff% = False
  78.    END IF
  79.    IF Refreshing% THEN CurCtr% = 0
  80.    RETURN
  81.                                                                    
  82. END FUNCTION
  83.  
  84. FUNCTION GPLine% (GLine%, GCol%, Text$)
  85.    GPLine% = -1
  86.    IF GLine% > CS.NbrLines OR GCol% > CS.NbrCols THEN EXIT FUNCTION
  87.    Res% = CalcGPos%(GLine%, GCol%, VPos, HPos)
  88.    XPPos = HPos + GetGTextLen%(Text$)
  89.    IF XPPos > CS.XMax THEN EXIT FUNCTION
  90.    Res% = OutGText%(HPos, VPos, Text$)
  91.    GPLine% = GCol% + LEN(Text$)
  92. END FUNCTION
  93.  
  94. FUNCTION GSpace% (GLine%, GCol%, GColor%)
  95.    Res% = CalcGPos%(GLine%, GCol%, VPos, HPos)
  96.    LINE (HPos, VPos)-(HPos + FI.AvgWidth, VPos + FI.PixHeight), GColor%, BF
  97. END FUNCTION
  98.  
  99. SUB Pause (Msg$)
  100.    CCol% = POS(0)
  101.    CRow% = CSRLIN
  102.    LOCATE 25, 1: PRINT Msg$; : BEEP
  103.    WHILE INKEY$ = "": WEND
  104.    LOCATE 25, 1: PRINT STRING$(79, " ");
  105.    LOCATE CRow%, CCol%
  106. END SUB
  107.  
  108. SUB PrtFontInfo
  109.    PRINT "Number of Fonts Registered "; CS.NbrReg%
  110.    PRINT "Number of Fonts Loaded "; CS.NbrLoaded%
  111.    FOR I% = 1 TO CS.NbrReg%
  112.       GetRFontInfo I%, FI
  113.       PRINT "  Font number: "; FI.FontNum
  114.       PRINT "       Ascent: "; FI.Ascent
  115.       PRINT "       Points: "; FI.Points
  116.       PRINT "  Pixel Width: "; FI.PixWidth
  117.       PRINT " Pixel Height: "; FI.PixHeight
  118.       PRINT "      Leading: "; FI.Leading
  119.       PRINT "Average Width: "; FI.AvgWidth
  120.       PRINT "Maximum Width: "; FI.MaxWidth
  121.       DspFileName$ = LEFT$(FI.FileName, INSTR(FI.FileName, " ") - 1)
  122.       PRINT "    File Name: "; DspFileName$
  123.       PRINT "    Face Name: "; FI.FaceName
  124.       PRINT " "
  125.       PRINT "Press any key to view the next font specification."
  126.       WHILE INKEY$ = "": WEND
  127.       CLS
  128.    NEXT I%
  129.    Pause "Waiting for keypress..."
  130. END SUB
  131.  
  132. FUNCTION RegLoadFonts% (FileName$, FontNbr)
  133.    RegLoadFonts% = False      'Initialize status
  134.  
  135.    SetMaxFonts 10, 10
  136.    X$ = DIR$(FileName$)
  137.  
  138.    IF X$ = "" THEN
  139.       PRINT "The font file "; FileName$; " can't be found."
  140.       PRINT "Please place the file in the correct directory and restart the program"
  141.       EXIT FUNCTION
  142.    ELSE
  143.       CS.NbrReg% = RegisterFonts(FileName$)
  144.       IF CS.NbrReg% = 0 THEN
  145.          PRINT "Invalid Font File"
  146.          EXIT FUNCTION
  147.       ELSEIF FontErr THEN
  148.          PRINT "Font error #"; FontErr
  149.          EXIT FUNCTION
  150.       END IF
  151.    END IF
  152.  
  153.    IF FontNbr = 0 THEN     'Load all fonts
  154.       LoadStr$ = LEFT$("N1/N2/N3/N4/N5/N6/N7/N8/N9", CS.NbrReg% * 3 - 1)
  155.    ELSE                    'Load specific fonts
  156.       LoadStr$ = "N" + RIGHT$(STR$(FontNbr), 1)
  157.    END IF
  158.  
  159.    CS.NbrLoaded% = LoadFont(LoadStr$)
  160.    RegLoadFonts% = True       'Successful
  161. END FUNCTION
  162.  
  163. SUB ScreenSize (XMax%, YMax%)
  164.    SELECT CASE CurrentMode
  165.       CASE 1: XMax% = 320: YMax% = 200
  166.       CASE 2: XMax% = 640: YMax% = 200
  167.       CASE 3: XMax% = 720: YMax% = 350
  168.       CASE 4: XMax% = 640: YMax% = 400
  169.       CASE 7: XMax% = 320: YMax% = 200
  170.       CASE 8: XMax% = 640: YMax% = 200
  171.       CASE 9: XMax% = 640: YMax% = 350
  172.       CASE 10: XMax% = 640: YMax% = 350
  173.       CASE 11: XMax% = 640: YMax% = 480
  174.       CASE 12: XMax% = 640: YMax% = 480
  175.       CASE 13: XMax% = 320: YMax% = 200
  176.    END SELECT
  177. END SUB
  178.  
  179. FUNCTION SetFont% (FontNbr AS INTEGER, FontColor AS INTEGER)
  180.    IF FontNbr <> 0 OR FontNbr <= CS.NbrReg THEN
  181.       CurrentFont = FontNbr
  182.       SelectFont CurrentFont
  183.       GetRFontInfo CurrentFont, FI
  184.       CS.NbrLines = CS.YMax \ FI.PixHeight
  185.       CS.NbrCols = CS.XMax \ FI.AvgWidth
  186.       SetGTextColor FontColor
  187.       SetFont% = 0
  188.    ELSE
  189.       SetFont% = 1
  190.    END IF
  191. END FUNCTION
  192.  
  193. SUB SetScreen (FGColor%, BGColor%, SMode%)
  194.    CurrentMode = SMode%      'Set for EGA/VGA screen mode
  195.    SCREEN CurrentMode
  196.    CALL ScreenSize(CS.XMax, CS.YMax)
  197.    CS.FGColor = FGColor%
  198.    CS.BGColor = BGColor%
  199.    COLOR CS.FGColor, CS.BGColor   'Set screen colors
  200.    CLS
  201. END SUB
  202.  
  203.