home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
QBAS
/
IMB9003.ZIP
/
FONTSCR.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-03-01
|
6KB
|
203 lines
' $INCLUDE: 'E:\bc7\bin\t90feb\tFONTS\FontScr.BI'
DIM SHARED CS AS CurrentSetUp
DIM SHARED FI AS FontInfo
DIM SHARED Totalfonts AS INTEGER
DIM SHARED CurrentFont AS INTEGER
DIM SHARED CurrentMode AS INTEGER
FUNCTION CalcGPos% (GLine%, GCol%, VPos, HPos)
VPos = GLine% * FI.PixHeight - FI.PixHeight
HPos = GCol% * FI.AvgWidth - FI.AvgWidth
IF VPos > CS.YMax OR VPos < 0 OR HPos > CS.XMax OR HPos < 0 THEN
CalcGPos% = False
ELSE
CalcGPos% = True
END IF
END FUNCTION
FUNCTION GCentered% (GLine%, Text$)
GCol% = 1
Res% = CalcGPos%(GLine%, GCol%, VPos, HPos)
PPos% = (CS.XMax - GetGTextLen%(Text$)) \ 2
IF PPos% >= 0 THEN
PLen% = OutGText%(CSNG(PPos%), VPos, Text$)
END IF
GCentered% = PPos%
END FUNCTION
FUNCTION GInput$ (GLine%, GCol%, GLen%)
GPos% = GCol%
CR$ = CHR$(13): Tab$ = CHR$(9): Esc$ = CHR$(27)
TestStr$ = CR$ + Tab$ + Esc$
CurRefresh% = 300: CurCtr% = 0
SetCOff% = False: CurOff% = True 'Initialize cursor
DO
GOSUB DoCursor
a$ = INKEY$
EndChr% = (LEN(a$) * INSTR(TestStr$, a$)) > 0 'Mult then cmp because of instr null match
IF a$ <> "" AND NOT EndChr% THEN
SetCOff% = True
GOSUB DoCursor
IF a$ = CHR$(8) THEN
IF LEN(Istr$) > 0 THEN
Istr$ = LEFT$(Istr$, LEN(Istr$) - 1)
GPos% = GPos% - 1
Res% = GSpace(GLine%, GPos%, CS.BGColor%)
END IF
ELSE
SetGTextColor CS.FGColor%
Istr$ = Istr$ + a$
Res% = GPLine%(GLine%, GPos%, a$)
GPos% = GPos% + 1
END IF
SetCOff% = False
END IF
LOOP UNTIL EndChr% OR LEN(Istr$) = GLen%
SetCOff% = True
GOSUB DoCursor
GInput$ = Istr$
COLOR CS.FGColor%
EXIT FUNCTION
DoCursor:
CurCtr% = CurCtr% + 1
Refreshing% = CurCtr% > CurRefresh%
IF (Refreshing% AND NOT CurOff%) OR SetCOff% THEN 'Turn the cursor off
Res% = CalcGPos%(GLine%, GPos%, VPos, HPos)
COLOR CS.BGColor
LINE (HPos, VPos)-(HPos, VPos + FI.PixHeight)
CurOff% = True
ELSEIF (Refreshing% AND CurOff%) THEN 'Turn the cursor on
Res% = CalcGPos%(GLine%, GPos%, VPos, HPos)
COLOR CS.FGColor
LINE (HPos, VPos)-(HPos, VPos + FI.PixHeight)
CurOff% = False
END IF
IF Refreshing% THEN CurCtr% = 0
RETURN
END FUNCTION
FUNCTION GPLine% (GLine%, GCol%, Text$)
GPLine% = -1
IF GLine% > CS.NbrLines OR GCol% > CS.NbrCols THEN EXIT FUNCTION
Res% = CalcGPos%(GLine%, GCol%, VPos, HPos)
XPPos = HPos + GetGTextLen%(Text$)
IF XPPos > CS.XMax THEN EXIT FUNCTION
Res% = OutGText%(HPos, VPos, Text$)
GPLine% = GCol% + LEN(Text$)
END FUNCTION
FUNCTION GSpace% (GLine%, GCol%, GColor%)
Res% = CalcGPos%(GLine%, GCol%, VPos, HPos)
LINE (HPos, VPos)-(HPos + FI.AvgWidth, VPos + FI.PixHeight), GColor%, BF
END FUNCTION
SUB Pause (Msg$)
CCol% = POS(0)
CRow% = CSRLIN
LOCATE 25, 1: PRINT Msg$; : BEEP
WHILE INKEY$ = "": WEND
LOCATE 25, 1: PRINT STRING$(79, " ");
LOCATE CRow%, CCol%
END SUB
SUB PrtFontInfo
PRINT "Number of Fonts Registered "; CS.NbrReg%
PRINT "Number of Fonts Loaded "; CS.NbrLoaded%
FOR I% = 1 TO CS.NbrReg%
GetRFontInfo I%, FI
PRINT " Font number: "; FI.FontNum
PRINT " Ascent: "; FI.Ascent
PRINT " Points: "; FI.Points
PRINT " Pixel Width: "; FI.PixWidth
PRINT " Pixel Height: "; FI.PixHeight
PRINT " Leading: "; FI.Leading
PRINT "Average Width: "; FI.AvgWidth
PRINT "Maximum Width: "; FI.MaxWidth
DspFileName$ = LEFT$(FI.FileName, INSTR(FI.FileName, " ") - 1)
PRINT " File Name: "; DspFileName$
PRINT " Face Name: "; FI.FaceName
PRINT " "
PRINT "Press any key to view the next font specification."
WHILE INKEY$ = "": WEND
CLS
NEXT I%
Pause "Waiting for keypress..."
END SUB
FUNCTION RegLoadFonts% (FileName$, FontNbr)
RegLoadFonts% = False 'Initialize status
SetMaxFonts 10, 10
X$ = DIR$(FileName$)
IF X$ = "" THEN
PRINT "The font file "; FileName$; " can't be found."
PRINT "Please place the file in the correct directory and restart the program"
EXIT FUNCTION
ELSE
CS.NbrReg% = RegisterFonts(FileName$)
IF CS.NbrReg% = 0 THEN
PRINT "Invalid Font File"
EXIT FUNCTION
ELSEIF FontErr THEN
PRINT "Font error #"; FontErr
EXIT FUNCTION
END IF
END IF
IF FontNbr = 0 THEN 'Load all fonts
LoadStr$ = LEFT$("N1/N2/N3/N4/N5/N6/N7/N8/N9", CS.NbrReg% * 3 - 1)
ELSE 'Load specific fonts
LoadStr$ = "N" + RIGHT$(STR$(FontNbr), 1)
END IF
CS.NbrLoaded% = LoadFont(LoadStr$)
RegLoadFonts% = True 'Successful
END FUNCTION
SUB ScreenSize (XMax%, YMax%)
SELECT CASE CurrentMode
CASE 1: XMax% = 320: YMax% = 200
CASE 2: XMax% = 640: YMax% = 200
CASE 3: XMax% = 720: YMax% = 350
CASE 4: XMax% = 640: YMax% = 400
CASE 7: XMax% = 320: YMax% = 200
CASE 8: XMax% = 640: YMax% = 200
CASE 9: XMax% = 640: YMax% = 350
CASE 10: XMax% = 640: YMax% = 350
CASE 11: XMax% = 640: YMax% = 480
CASE 12: XMax% = 640: YMax% = 480
CASE 13: XMax% = 320: YMax% = 200
END SELECT
END SUB
FUNCTION SetFont% (FontNbr AS INTEGER, FontColor AS INTEGER)
IF FontNbr <> 0 OR FontNbr <= CS.NbrReg THEN
CurrentFont = FontNbr
SelectFont CurrentFont
GetRFontInfo CurrentFont, FI
CS.NbrLines = CS.YMax \ FI.PixHeight
CS.NbrCols = CS.XMax \ FI.AvgWidth
SetGTextColor FontColor
SetFont% = 0
ELSE
SetFont% = 1
END IF
END FUNCTION
SUB SetScreen (FGColor%, BGColor%, SMode%)
CurrentMode = SMode% 'Set for EGA/VGA screen mode
SCREEN CurrentMode
CALL ScreenSize(CS.XMax, CS.YMax)
CS.FGColor = FGColor%
CS.BGColor = BGColor%
COLOR CS.FGColor, CS.BGColor 'Set screen colors
CLS
END SUB