home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
basic
/
library
/
pb
/
library4
/
misc-u.bas
< prev
next >
Wrap
BASIC Source File
|
1990-09-16
|
14KB
|
532 lines
' ╔════════════════════════════╗
' ║ ║
' ║ 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
%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, Foo
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) = "D DELETE RECORD"
MenuHelpLine$(4) = "erase this record"
FileFun$(5) = "END"
RETURN
KeyFldExistRec:
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
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$
FZ$ = F$ + CHR$(0)
REG %DS, STRSEG (FZ$)
REG %DX, STRPTR (FZ$)
REG %CX, &H17
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$