Category : Recently Uploaded Files
Archive   : BASIC1A.ZIP
Filename : MISC-U.BAS
' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
' º º
' º MISC_U.BAS º
' º º
' º H.B. LIBRARY LEFTOVERS º
' º º
' ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ
$COMPILE UNIT
$ERROR ALL OFF
%False = 0
%True = NOT %False
%FLAGS = 0: %AX = 1: %BX = 2: %CX = 3: %DX = 4
%SI = 5: %DI = 6: %BP = 7: %DS = 8: %ES = 9
%ResetRodent = 0 ' mouse routine and humor (??) courtesy of Barry Erick
%ReadRodent = 3
%CheckScreensSaved = %False
DEFINT A-Z
DECLARE SUB SUPERMENU (string array,integer,integer,integer,string,integer)
EXTERNAL Footer$, CurrLine, LineGroup, Page%, NewRec, KeyField, PullDown
EXTERNAL OopsBeep$, InitPrt$, FontCode$, NextScrn2Pop, ScrnStackSize
EXTERNAL ScreenStack$ (), VideoSeg&, OrigL, OrigC, ReverseLF$, NeedDCon
EXTERNAL MenuHelpLine$()
' _____________________________________________________
SUB SCREENPUSH PUBLIC
DEF SEG = VideoSeg&
INCR NextScrn2Pop
$IF %CheckScreensSaved
FOR N = 1 TO 9: LPRINT ReverseLF$;: NEXT
LPRINT "SCREEN PUSHED: "; NextScrn2Pop
FOR N = 1 TO 9: LPRINT: NEXT
$ENDIF
IF NextScrn2Pop =< ScrnStackSize THEN
ScreenStack$ (NextScrn2Pop) = PEEK$ (0, 4000)
ELSE
BSAVE RD$ + "SCRN_" + LTRIM$(STR$(NextScrn2Pop)), 0, 4000
END IF
DEF SEG
END SUB REM PUSHSCREEN
' _____________________________________________________
SUB SCREENPOP PUBLIC
DEF SEG = VideoSeg&
$IF %CheckScreensSaved
FOR N = 1 TO 9: LPRINT ReverseLF$;: NEXT
LPRINT " SCREEN POPPED: "; NextScrn2Pop
FOR N = 1 TO 9: LPRINT: NEXT
$ENDIF
IF NextScrn2Pop < 1 THEN
FOR N = 1 TO 10: LOCATE 2*N, 5*N: PRINT "SCREEN STACK UNDERFLOW": NEXT
ELSEIF NextScrn2Pop =< ScrnStackSize THEN
POKE$ 0, ScreenStack$ (NextScrn2Pop)
ELSE
BLOAD RD$ + "SCRN_" + LTRIM$(STR$(NextScrn2Pop))
END IF
DECR NextScrn2Pop
DEF SEG
END SUB REM POPSCREEN
' _____________________________________________________
SUB RestoreDOSScreen PUBLIC
NextScrn2Pop = 1
CALL SCREENPOP
LOCATE OrigL, OrigC
END SUB
' =============================================================================
SUB PRINTLINE (L$) PUBLIC
LOCAL NL, I
NL = %PageLength - %TopMargin - %BottomMargin
IF Footer$ <> "" THEN DECR NL, 2
IF Header$ <> "" THEN DECR NL, 2
' line comes in as a passed string. increase line counter ...
INCR CurrLine
IF UCASE$ (L$) = "START" THEN
CurrLine = 1
Page% = 1
LPRINT InitPrt$ + FontCode$;
FOR I = 1 TO %TopMargin: LPRINT: NEXT
' IF PAGE IS FULL, OR DOESN'T HAVE ROOM FOR LineGroup LINES, PRINT FOOTER ...
ELSEIF CurrLine + LineGroup > NL OR UCASE$ (L$) = "END" THEN
IF Footer$ <> "" THEN GOSUB PPrintFoot
INCR Page%: CurrLine = 1: LPRINT CHR$(12)
' ... AND IF THERE'S MORE TO PRINT, ALSO A HEADER ...
IF UCASE$(L$) <> "END" AND Header$ <> "" THEN_
FOR I = 1 TO %TopMargin: LPRINT: NEXT: GOSUB PPrintHead
END IF
' NOW PRINT THE LINE AND EXIT
IF UCASE$(L$) = "END" THEN
Page% = 0
LPRINT InitPrt$;
ELSEIF UCASE$(L$) <> "START" THEN
LPRINT L$
END IF
EXIT SUB
PPrintHead:
LPRINT Header$;
IF INSTR (UCASE$ (RIGHT$(Header$,8)), "PAGE") THEN
LPRINT Page%
ELSE
LPRINT
END IF
LPRINT: RETURN
PPrintFoot:
LPRINT
LPRINT Footer$;
IF INSTR (UCASE$ (RIGHT$(Footer$,8)), "PAGE") THEN
LPRINT Page%
ELSE
LPRINT
END IF
RETURN
END SUB REM PRINTLINE
' =========================================================================
FUNCTION GetFileFunction$ PUBLIC
LOCAL Choice, Title$, Ky%, FileFun$ ()
DIM DYNAMIC FileFun$ (24)
IF NewRec THEN
IF KeyField THEN GOSUB KeyFldNewRec ELSE GOSUB NonkeyfldNewRec
ELSE
IF KeyField THEN GOSUB KeyFldExistRec ELSE GOSUB NonkeyFldExistRec
END IF
Choice = 1
CALL SCREENPUSH
CALL SUPERMENU (FileFun$ (), 0, 30, Choice, "FILE FUNCTION", Ky%)
CALL SCREENPOP
IF Choice = 0 THEN
GetFileFunction$ = ""
ELSE
GetFileFunction$ = LEFT$ (FileFun$(Choice), 1)
END IF
ERASE FileFun$
EXIT FUNCTION
KeyFldNewRec:
FileFun$(1) = "C CLEAR DATA FIELDS"
MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
FileFun$(2) = "F FIND A MATCH"
MenuHelpLine$(2) = "match entry in this field as closely as possible"
FileFun$(3) = "S SAVE RECORD"
MenuHelpLine$(3) = "write data shown into a new record"
FileFun$(4) = "V VIEW MEMOS"
MenuHelpLine$(4) = "add extra notes on this entry"
FileFun$(5) = "D DELETE RECORD"
MenuHelpLine$(5) = "erase this record"
FileFun$(6) = "END"
RETURN
KeyFldExistRec:
FileFun$(1) = "C CLEAR DATA FIELDS"
MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
FileFun$(2) = "N NEXT IN ORDER
MenuHelpLine$(2) = "continue the search forward"
FileFun$(3) = "P PREVIOUS RECORD"
MenuHelpLine$(3) = "back up, search in reverse"
FileFun$(4) = "S SAVE RECORD"
MenuHelpLine$(4) = "update this record using entries shown"
FileFun$(5) = "V VIEW MEMOS"
MenuHelpLine$(5)_
= "read extra notes on this entry if any; edit / change; or add"
FileFun$(6) = "D DELETE RECORD"
MenuHelpLine$(6) = "erase this record"
FileFun$(7) = "END"
RETURN
NonkeyFldNewRec:
FileFun$(1) = "C CLEAR DATA FIELDS"
MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
FileFun$(2) = "S SAVE RECORD"
MenuHelpLine$(2) = "write data shown into a new record"
FileFun$(3) = "D DELETE RECORD"
MenuHelpLine$(3) = "erase this record"
FileFun$(4) = "END"
RETURN
NonkeyFldExistRec:
FileFun$(1) = "C CLEAR DATA FIELDS"
MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
FileFun$(2) = "S SAVE RECORD"
MenuHelpLine$(2) = "update this record using entries shown
FileFun$(3) = "V VIEW MEMOS"
MenuHelpLine$(3) = "read extra notes on this entry if any; edit / change; or add"
FileFun$(4) = "D DELETE RECORD"
MenuHelpLine$(4) = "erase this record
FileFun$(5) = "END"
RETURN
END FUNCTION
'=============================================================================
FUNCTION IsBlank (W$) PUBLIC
IF RTRIM$ (W$) = "" THEN
IsBlank = %True
ELSE
IsBlank = %False
END IF
END FUNCTION
FUNCTION GetAttr PUBLIC
DEF SEG = VideoSeg&
GetAttr = PEEK ((80*CSRLIN-80 + POS - 1) * 2) + 1
DEF SEG
END FUNCTION
FUNCTION IsRodent PUBLIC ' finds if you have a rodent and also resets it
REG %AX, %ResetRodent
CALL INTERRUPT &H33
IsRodent = REG(%AX) ' true if present
END FUNCTION
SUB Mouse(MV1, MV2, MV3, MV4) PUBLIC
REG %AX, MV1: REG %BX, MV2: REG %CX, MV3: REG %DX, MV4
CALL INTERRUPT &H33
MV1 = REG(%AX): MV2 = REG(%BX): MV3 = REG(%CX): MV4 = REG(%DX)
END SUB
' _________________________________________________________________________
FUNCTION MouseClicked PUBLIC
LOCAL MC, X, Y
IF NeedDCon THEN
CALL Mouse (%ReadRodent, MC, X, Y)
MouseClicked = MC
ELSE
MouseClicked = 0
END IF
END FUNCTION
' _________________________________________________________________________
FUNCTION GetCurrentDrive$ PUBLIC
REG %AX, &H1900
CALL INTERRUPT &H21
GetCurrentDrive$ = CHR$ ((REG (%AX) AND &B00001111) + 65) + ":"
END FUNCTION
FUNCTION GetCurrentDir$ (Drv$) PUBLIC
STATIC Dummy$
Dummy$ = SPACE$ (64)
REG %AX, &H4700
IF Drv$ = "" THEN
REG %DX, 0 ' for default drive
ELSE
REG %DX, (ASC(UCASE$(Drv$))-64)
END IF
REG %DS, STRSEG (Dummy$)
REG %SI, STRPTR (Dummy$)
CALL INTERRUPT &H21
GetCurrentDir$ = "\" + EXTRACT$ (Dummy$, CHR$(0))
END FUNCTION ' ========================== GetCurrentDir$ ()
FUNCTION GetFreeSpace! (Drv$) PUBLIC
IF Drv$ = "" THEN
REG %DX, 0 ' for default drive
ELSE
REG %DX, (ASC(UCASE$(Drv$))-64)
END IF
REG %AX, &H3600 ' dos function number &H36 into AH
CALL INTERRUPT &H21
GetFreeSpace! = CSNG (REG(%BX)) * REG (%CX) * REG (%AX)
' free clusters * byt/sect * sect/cluster
END FUNCTION ' ----------
FUNCTION ReadParamFor (A$) PUBLIC ' this reads parameters from the command tail
LOCAL L, N
L = INSTR (COMMAND$, A$)
IF L THEN
N = VAL ("&H"+MID$ (COMMAND$, L + 5, 2))
IF N THEN ReadParamFor = N
END IF
END FUNCTION ' ----------
SUB ClearLine PUBLIC
LOCAL CLL0, CLC0
CLL0 = CSRLIN
CLC0 = POS
PRINT STRING$ ((81-CLC0)," "); ' this almost fills the line ...
LOCATE CLL0, CLC0
END SUB ' ----------
' ============================================================================
SUB DirFirst (F$, FileSize&, DateCode&, TimeCode&) PUBLIC
LOCAL DTASeg&, AttrOffset&, FlNOffset&, SearchErr, FlN$, N
FlN$ = F$ + CHR$(0)
REG %DS, STRSEG (FlN$)
REG %DX, STRPTR (FlN$)
REG %CX, &H17
REG %AX, &H4E00
CALL INTERRUPT &H21
SearchErr = REG(%AX)
IF SearchErr THEN
F$ = ""
EXIT SUB
END IF
REG %AX, &H2F00
CALL INTERRUPT &H21
DTAseg& = REG(%ES)
AttrOffset& = REG(%BX) + &H15
FlNOffset& = REG(%BX) + &H1E
TimeOffset& = REG(%BX) + &H16
DateOffset& = REG(%BX) + &H18
SizeOffset& = REG(%BX) + &H1A
FlN$ = ""
DEF SEG = DTAseg&
N = 0
DO UNTIL PEEK (FlNOffset& + N) = 0 ' read the ASCIIZ file-name string
FlN$ = FlN$ + CHR$ (PEEK (FlNOffset& + N))
INCR N
LOOP
IF (PEEK(AttrOffset&) AND 16) = 16 THEN ' bracket if a subdirectory
FlN$ = "<"+FlN$+">"
END IF
FileSize& = CVL (PEEK$ (SizeOffset&, 4))
DateCode& = PEEK (DateOffset&) + &H100 * PEEK (DateOffset& + 1)
TimeCode& = PEEK (TimeOffset&) + &H100 * PEEK (TimeOffset& + 1)
DEF SEG
F$ = FlN$
END SUB
' ===========================
SUB DirNext (F$, FileSize&, DateCode&, TimeCode&) PUBLIC
LOCAL FlN$, DTAseg&, FlNOffset&, AttrOffset&, N
REG %AX, &H4F00
CALL INTERRUPT &H21
IF REG(%AX) = 18 THEN
F$ = ""
EXIT SUB
END IF
REG %AX, &H2F00
CALL INTERRUPT &H21
DTAseg& = REG(%ES)
AttrOffset& = REG(%BX) + 21
FlNOffset& = REG(%BX) + &H1E
TimeOffset& = REG(%BX) + &H16
DateOffset& = REG(%BX) + &H18
SizeOffset& = REG(%BX) + &H1A
FlN$ = ""
DEF SEG = DTAseg&
DO UNTIL PEEK (FlNOffset& + N) = 0
FlN$ = FlN$ + CHR$(PEEK(FlNOffset& + N))
INCR N
LOOP
IF (PEEK(AttrOffset&) AND 16) = 16 THEN
FlN$ = "<"+FlN$+">" ' subdirs will come back w/ brackets
END IF
FileSize& = CVL (PEEK$ (SizeOffset&, 4))
DateCode& = PEEK (DateOffset&) + &H100 * PEEK (DateOffset& + 1)
TimeCode& = PEEK (TimeOffset&) + &H100 * PEEK (TimeOffset& + 1)
DEF SEG
F$ = FlN$
END SUB
' ========================================
FUNCTION DecodeDate$ (DateCode&) PUBLIC
LOCAL M, D, Y
Y = DateCode&\512
M = (DateCode& MOD 512) \ 32
D = DateCode& MOD 32
DecodeDate$ = LTRIM$ (STR$ (M)) + "-" +_
STRING$ (1 + (D > 9), "0") + LTRIM$ (STR$ (D)) + "-" +_
LTRIM$ (STR$ (Y + 80))
END FUNCTION ' ============================ DecodeDate$ ()
FUNCTION DecodeTime$ (TimeCode&) PUBLIC
LOCAL H, H24, M
H24 = INT(TimeCode&\2048)
IF H24 > 12 THEN
H = H24 - 12
pm = %True
ELSE
H = H24
pm = %False
END IF
IF H = 0 THEN H = 12
M = (TimeCode&-(CLNG(H24)*2048))\32
DecodeTime$ = STRING$ (1 + (H > 9), " ") + LTRIM$ (STR$ (H)) + ":" +_
STRING$ (1 + (M > 9), "0") + LTRIM$ (STR$ (M)) +_
MID$ (" pm am", pm*3+4, 3)
END FUNCTION ' ============================ DecodeTime$ ()
FUNCTION EXIST (F$) PUBLIC
LOCAL SearchErr, FZ$
REG %AX, &H2F00
CALL INTERRUPT &H21 ' GET DOS'S D.T.A.
' (in FEXIST.BOX Barry gets out the DTA addr but
' never uses it. It's ES:BX.)
FZ$ = F$ + CHR$(0)
REG %DS, STRSEG (FZ$)
REG %DX, STRPTR (FZ$)
REG %CX, &H7
REG %AX, &H4E00
CALL INTERRUPT &H21
SearchErr = REG(%AX)
SELECT CASE SearchErr
CASE 2, 3, 15, 18
EXIST = 0
CASE ELSE
EXIST = -1
END SELECT
DEF SEG
END Function ' ================== EXIST ()
FUNCTION FQFileSpec$ (A$) PUBLIC
LOCAL CurrentDir$, CurrentDrv$ ' Of course there's a DOS function
CurrentDrv$ = GetCurrentDrive$ ' that does something like this --
CurrentDir$ = GetCurrentDir$ ("") ' maybe exactly this! I never did
' try it out. So this may be the
A$ = REMOVE$ (A$, " ") ' hard way!
IF INSTR (A$, ANY "^/,<>+()|"+CHR$(34)) THEN
FQFileSpec$ = "": EXIT FUNCTION
END IF
SELECT CASE INSTR (A$, ":")
CASE 0
IF INSTR (A$, "\") THEN
A$ = CurrentDrv$ + A$
ELSE
A$ = CurrentDrv$ + CurrentDir$ +"\"+ A$
END IF
EXIT SELECT
CASE 2
IF INSTR (A$, "\") = %False THEN
CurrentDir$ = GetCurrentDir$ (LEFT$(A$,1))
END IF
EXIT SELECT
CASE ELSE
PLAY "O0 C64": FQFileSpec$ = "": EXIT FUNCTION
END SELECT
IF INSTR (A$, "\") = %False THEN
IF RIGHT$ (A$, 1) = ":" THEN
A$ = A$ + CurrentDir$ + "\"
ELSEIF CurrentDir$ = "\" THEN
A$ = LEFT$ (A$, 2) + "\" + MID$ (A$, 3)
ELSE
A$ = LEFT$ (A$, 2) + CurrentDir$ + "\" + MID$ (A$, 3)
END IF
END IF
IF RIGHT$ (A$, 1) = "\" THEN A$ = A$ + "*.*"
REPLACE "\\" WITH "\" IN A$
FQFileSpec$ = A$
END FUNCTION ' ========= FQFileSpec$
FUNCTION Cen$ (A$) PUBLIC
Cen$ = SPACE$ (40 - LEN (A$)\2) + A$
END FUNCTION
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/