home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / pb / library4 / misc-u.bas < prev    next >
Encoding:
BASIC Source File  |  1990-09-16  |  13.7 KB  |  532 lines
  1.  
  2. '                      ╔════════════════════════════╗
  3. '                      ║                            ║
  4. '                      ║         MISC_U.BAS         ║
  5. '                      ║                            ║
  6. '                      ║   H.B. LIBRARY LEFTOVERS   ║
  7. '                      ║                            ║
  8. '                      ╚════════════════════════════╝
  9.  
  10.  
  11.                             $COMPILE UNIT
  12.                             $ERROR ALL OFF
  13.  
  14.   %False = 0
  15.   %True = NOT %False
  16.   %FLAGS = 0:  %AX = 1:  %BX = 2:  %CX = 3:  %DX = 4
  17.                          %SI = 5:  %DI = 6:  %BP = 7:  %DS = 8:  %ES = 9
  18.  
  19.  %ReadRodent = 3
  20.  %CheckScreensSaved = %False
  21.  
  22.  DEFINT A-Z
  23.  
  24.  DECLARE SUB SUPERMENU (string array,integer,integer,integer,string,integer)
  25.  
  26.  EXTERNAL Footer$, CurrLine, LineGroup, Page%, NewRec, KeyField, PullDown
  27.  EXTERNAL OopsBeep$, InitPrt$, FontCode$, NextScrn2Pop, ScrnStackSize, Foo
  28.  EXTERNAL ScreenStack$ (), VideoSeg&, OrigL, OrigC,  ReverseLF$, NeedDCon
  29.  EXTERNAL MenuHelpLine$()
  30.  
  31.  
  32. '            _____________________________________________________
  33.  
  34.  
  35. SUB SCREENPUSH PUBLIC
  36.  
  37.  DEF SEG = VideoSeg&
  38.  
  39.  INCR NextScrn2Pop
  40.                        $IF %CheckScreensSaved
  41.  
  42.  FOR N = 1 TO 9: LPRINT ReverseLF$;: NEXT
  43.  LPRINT "SCREEN PUSHED: "; NextScrn2Pop
  44.  FOR N = 1 TO 9: LPRINT: NEXT
  45.                                                 $ENDIF
  46.  IF NextScrn2Pop =< ScrnStackSize THEN
  47.    ScreenStack$ (NextScrn2Pop) = PEEK$ (0, 4000)
  48.  ELSE
  49.    BSAVE RD$ + "SCRN_" + LTRIM$(STR$(NextScrn2Pop)), 0, 4000
  50.  END IF
  51.  
  52.  DEF SEG
  53.  END SUB                                                      REM PUSHSCREEN
  54. '            _____________________________________________________
  55.  
  56. SUB SCREENPOP PUBLIC
  57.  DEF SEG = VideoSeg&
  58.                        $IF %CheckScreensSaved
  59.  FOR N = 1 TO 9: LPRINT ReverseLF$;: NEXT
  60.  LPRINT "                                SCREEN POPPED: "; NextScrn2Pop
  61.  FOR N = 1 TO 9: LPRINT: NEXT
  62.                                             $ENDIF
  63.  IF NextScrn2Pop < 1 THEN
  64.    FOR N = 1 TO 10: LOCATE 2*N, 5*N: PRINT "SCREEN STACK UNDERFLOW": NEXT
  65.  ELSEIF NextScrn2Pop =< ScrnStackSize THEN
  66.    POKE$ 0, ScreenStack$ (NextScrn2Pop)
  67.  ELSE
  68.    BLOAD RD$ + "SCRN_" + LTRIM$(STR$(NextScrn2Pop))
  69.  END IF
  70.  
  71.  DECR NextScrn2Pop
  72.  
  73.  DEF SEG
  74.  END SUB                                                      REM POPSCREEN
  75. '            _____________________________________________________
  76.  
  77.  
  78.  
  79.  
  80. SUB RestoreDOSScreen PUBLIC
  81.  NextScrn2Pop = 1
  82.  CALL SCREENPOP
  83.  LOCATE OrigL, OrigC
  84.  END SUB
  85.  
  86. ' ============================================================================
  87.  
  88.  
  89. ' =============================================================================
  90.  
  91.  
  92.  
  93.  
  94. SUB PRINTLINE (L$) PUBLIC
  95.  LOCAL NL, I
  96.  
  97.  NL = %PageLength - %TopMargin - %BottomMargin
  98.  IF Footer$ <> "" THEN DECR NL, 2
  99.  IF Header$ <> "" THEN DECR NL, 2
  100.  
  101. '                    line comes in as a passed string. increase line counter ...
  102.  INCR CurrLine
  103.  IF UCASE$ (L$) = "START" THEN
  104.    CurrLine = 1
  105.    Page% = 1
  106.    LPRINT  InitPrt$ + FontCode$;
  107.    FOR I = 1 TO %TopMargin: LPRINT: NEXT
  108.  
  109. '   IF PAGE IS FULL, OR DOESN'T HAVE ROOM FOR LineGroup LINES, PRINT FOOTER ...
  110.  
  111.  ELSEIF CurrLine + LineGroup > NL OR UCASE$ (L$) = "END" THEN
  112.     IF Footer$ <> "" THEN GOSUB PPrintFoot
  113.     INCR Page%: CurrLine = 1: LPRINT CHR$(12)
  114. '                       ... AND IF THERE'S MORE TO PRINT, ALSO A HEADER ...
  115.     IF UCASE$(L$) <> "END" AND Header$ <> "" THEN_
  116.                       FOR I = 1 TO %TopMargin: LPRINT: NEXT: GOSUB PPrintHead
  117.  END IF
  118.  
  119. '                                               NOW PRINT THE LINE AND EXIT
  120.  IF UCASE$(L$) = "END" THEN
  121.    Page% = 0
  122.    LPRINT  InitPrt$;
  123.  ELSEIF UCASE$(L$) <> "START" THEN
  124.    LPRINT L$
  125.  END IF
  126.  EXIT SUB
  127.  
  128. PPrintHead:
  129.    LPRINT Header$;
  130.    IF INSTR (UCASE$ (RIGHT$(Header$,8)), "PAGE") THEN
  131.      LPRINT Page%
  132.    ELSE
  133.      LPRINT
  134.    END IF
  135.    LPRINT: RETURN
  136.  
  137. PPrintFoot:
  138.    LPRINT
  139.    LPRINT Footer$;
  140.    IF INSTR (UCASE$ (RIGHT$(Footer$,8)), "PAGE") THEN
  141.      LPRINT Page%
  142.    ELSE
  143.      LPRINT
  144.    END IF
  145.    RETURN
  146.  
  147.      END SUB                                              REM PRINTLINE
  148.  
  149.  
  150. ' =========================================================================
  151.  
  152.  
  153.  FUNCTION GetFileFunction$ PUBLIC
  154.  
  155.  LOCAL Choice, Title$, Ky%, FileFun$ ()
  156.  DIM DYNAMIC FileFun$ (24)
  157.  
  158.  
  159.  IF NewRec THEN
  160.    IF KeyField THEN GOSUB KeyFldNewRec ELSE GOSUB NonkeyfldNewRec
  161.  ELSE
  162.    IF KeyField THEN GOSUB KeyFldExistRec ELSE GOSUB NonkeyFldExistRec
  163.  END IF
  164.  
  165.  Choice = 1
  166.  
  167.       CALL SCREENPUSH
  168.       CALL SUPERMENU (FileFun$ (), 0, 30, Choice, "FILE FUNCTION", Ky%)
  169.       CALL SCREENPOP
  170.  
  171.  IF Choice = 0 THEN
  172.    GetFileFunction$ = ""
  173.  ELSE
  174.    GetFileFunction$ = LEFT$ (FileFun$(Choice), 1)
  175.  END IF
  176.  
  177.  ERASE FileFun$
  178.  
  179.  EXIT FUNCTION
  180.  
  181. KeyFldNewRec:
  182.  FileFun$(1) = "C CLEAR DATA FIELDS"
  183.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  184.  FileFun$(2) = "F FIND A MATCH"
  185.  MenuHelpLine$(2) = "match entry in this field as closely as possible"
  186.  FileFun$(3) = "S SAVE RECORD"
  187.  MenuHelpLine$(3) = "write data shown into a new record"
  188.  FileFun$(4) = "D DELETE RECORD"
  189.  MenuHelpLine$(4) = "erase this record"
  190.  FileFun$(5) = "END"
  191.  RETURN
  192.  
  193. KeyFldExistRec:
  194.  FileFun$(1) = "C CLEAR DATA FIELDS"
  195.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  196.  FileFun$(2) = "S SAVE RECORD"
  197.  MenuHelpLine$(2) = "update this record using entries shown"
  198.  FileFun$(3) = "V VIEW MEMOS"
  199.  MenuHelpLine$(3) = "read extra notes on this entry if any; edit / change; or add"
  200.  FileFun$(4) = "D DELETE RECORD"
  201.  MenuHelpLine$(4) = "erase this record"
  202.  FileFun$(5) = "END"
  203.  RETURN
  204.  
  205. NonkeyFldNewRec:
  206.  FileFun$(1) = "C CLEAR DATA FIELDS"
  207.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  208.  FileFun$(2) = "S SAVE RECORD"
  209.  MenuHelpLine$(2) = "write data shown into a new record"
  210.  FileFun$(3) = "D DELETE RECORD"
  211.  MenuHelpLine$(3) = "erase this record"
  212.  FileFun$(4) = "END"
  213.  RETURN
  214.  
  215. NonkeyFldExistRec:
  216.  FileFun$(1) = "C CLEAR DATA FIELDS"
  217.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  218.  FileFun$(2) = "S SAVE RECORD"
  219.  MenuHelpLine$(2) = "update this record using entries shown
  220.  FileFun$(3) = "V VIEW MEMOS"
  221.  MenuHelpLine$(3) = "read extra notes on this entry if any; edit / change; or add"
  222.  FileFun$(4) = "D DELETE RECORD"
  223.  MenuHelpLine$(4) = "erase this record
  224.  FileFun$(5) = "END"
  225.  RETURN
  226.  
  227.  END FUNCTION
  228.  
  229. '=============================================================================
  230.  
  231.  FUNCTION IsBlank (W$) PUBLIC
  232.    IF RTRIM$ (W$) = "" THEN
  233.      IsBlank = %True
  234.    ELSE
  235.      IsBlank = %False
  236.    END IF
  237.  END FUNCTION
  238.  
  239.  
  240. FUNCTION GetAttr PUBLIC
  241.  DEF SEG = VideoSeg&
  242.  GetAttr = PEEK ((80*CSRLIN-80 + POS - 1) * 2) + 1
  243.  DEF SEG
  244.  END FUNCTION
  245.  
  246.  
  247. FUNCTION IsRodent PUBLIC    '     finds if you have a rodent and also resets it
  248.  REG %AX, %ResetRodent
  249.  CALL INTERRUPT &H33
  250.  IsRodent = REG(%AX) '                                          true if present
  251. END FUNCTION
  252.  
  253.  
  254. SUB Mouse(MV1, MV2, MV3, MV4) PUBLIC
  255.  
  256.  REG %AX, MV1: REG %BX, MV2: REG %CX, MV3: REG %DX, MV4
  257.  CALL INTERRUPT &H33
  258.  MV1 = REG(%AX): MV2 = REG(%BX): MV3 = REG(%CX): MV4 = REG(%DX)
  259.  
  260. END SUB
  261. ' _________________________________________________________________________
  262.  
  263. FUNCTION MouseClicked PUBLIC
  264.  LOCAL MC, X, Y
  265.  IF NeedDCon THEN
  266.    CALL Mouse (%ReadRodent, MC, X, Y)
  267.    MouseClicked = MC
  268.  ELSE
  269.    MouseClicked = 0
  270.  END IF
  271. END FUNCTION
  272. ' _________________________________________________________________________
  273.  
  274. FUNCTION GetCurrentDrive$ PUBLIC
  275.    REG %AX, &H1900
  276.    CALL INTERRUPT &H21
  277.    GetCurrentDrive$ = CHR$ ((REG (%AX) AND &B00001111) + 65) + ":"
  278.  
  279. END FUNCTION
  280.  
  281. FUNCTION GetCurrentDir$ (Drv$) PUBLIC
  282.    STATIC Dummy$
  283.    Dummy$ = SPACE$ (64)
  284.  
  285.    REG %AX, &H4700
  286.  
  287.    IF Drv$ = "" THEN
  288.      REG %DX, 0 '     for default drive
  289.    ELSE
  290.      REG %DX, (ASC(UCASE$(Drv$))-64)
  291.    END IF
  292.  
  293.    REG %DS, STRSEG (Dummy$)
  294.    REG %SI, STRPTR (Dummy$)
  295.  
  296.    CALL INTERRUPT &H21
  297.  
  298.    GetCurrentDir$ = "\" + EXTRACT$ (Dummy$, CHR$(0))
  299.  
  300. END FUNCTION '             ==========================        GetCurrentDir$ ()
  301.  
  302. FUNCTION GetFreeSpace! (Drv$) PUBLIC
  303.    IF Drv$ = "" THEN
  304.      REG %DX, 0 '     for default drive
  305.    ELSE
  306.      REG %DX, (ASC(UCASE$(Drv$))-64)
  307.    END IF
  308.    REG %AX, &H3600  '     dos function number &H36 into AH
  309.    CALL INTERRUPT &H21
  310.    GetFreeSpace! = CSNG (REG(%BX)) * REG (%CX) * REG (%AX)
  311. '                     free clusters  * byt/sect  * sect/cluster
  312.  
  313. END FUNCTION '                    ----------
  314.  
  315. FUNCTION ReadParamFor (A$) PUBLIC ' this reads parameters from the command tail
  316.  LOCAL L, N
  317.  L = INSTR (COMMAND$, A$)
  318.  IF L THEN
  319.    N = VAL ("&H"+MID$ (COMMAND$, L + 5, 2))
  320.    IF N THEN ReadParamFor = N
  321.  END IF
  322.  END FUNCTION '                    ----------
  323.  
  324. SUB ClearLine PUBLIC
  325.  
  326.  LOCAL CLL0, CLC0
  327.  
  328.  CLL0 = CSRLIN
  329.  CLC0 = POS
  330.  PRINT STRING$ ((81-CLC0)," ");    ' this almost fills the line ...
  331.  LOCATE CLL0, CLC0
  332.  
  333.  END SUB '                    ----------  
  334.  
  335. ' ============================================================================
  336.  
  337.  
  338. SUB DirFirst (F$, FileSize&, DateCode&, TimeCode&) PUBLIC
  339.  
  340.  LOCAL DTASeg&, AttrOffset&, FlNOffset&, SearchErr, FlN$, N
  341.  
  342.  FlN$ = F$ + CHR$(0)
  343.  REG %DS, STRSEG (FlN$)
  344.  REG %DX, STRPTR (FlN$)
  345.  REG %CX, &H17
  346.  REG %AX, &H4E00
  347.  CALL INTERRUPT &H21
  348.  SearchErr = REG(%AX)
  349.  IF SearchErr THEN
  350.     F$ = ""
  351.     EXIT SUB
  352.  END IF
  353.  
  354.  REG %AX, &H2F00
  355.  
  356.     CALL INTERRUPT &H21
  357.  
  358.  DTAseg& = REG(%ES)
  359.  AttrOffset& = REG(%BX) + &H15
  360.  FlNOffset& = REG(%BX) + &H1E
  361.  TimeOffset& = REG(%BX) + &H16
  362.  DateOffset& = REG(%BX) + &H18
  363.  SizeOffset& = REG(%BX) + &H1A
  364.  
  365.  FlN$ = ""
  366.  DEF SEG = DTAseg&
  367.  N = 0
  368.  
  369.  DO UNTIL PEEK (FlNOffset& + N) = 0 '          read the ASCIIZ file-name string
  370.    FlN$ = FlN$ + CHR$ (PEEK (FlNOffset& + N))
  371.    INCR N
  372.  LOOP
  373.  
  374.  IF (PEEK(AttrOffset&) AND 16) = 16 THEN '        bracket if a subdirectory
  375.     FlN$ = "<"+FlN$+">"
  376.  END IF
  377.  
  378.  FileSize& = CVL (PEEK$ (SizeOffset&, 4))
  379.  DateCode& =  PEEK (DateOffset&) + &H100 * PEEK (DateOffset& + 1)
  380.  TimeCode& =  PEEK (TimeOffset&) + &H100 * PEEK (TimeOffset& + 1)
  381.  
  382.  DEF SEG
  383.  
  384.  F$ = FlN$
  385.  
  386.  END SUB
  387.  
  388. '                        ===========================
  389.  
  390.  
  391.  
  392.  SUB DirNext (F$, FileSize&, DateCode&, TimeCode&) PUBLIC
  393.  
  394.  LOCAL FlN$, DTAseg&, FlNOffset&, AttrOffset&, N
  395.  
  396.  REG %AX, &H4F00
  397.  CALL INTERRUPT &H21
  398.  IF REG(%AX) = 18 THEN
  399.     F$ = ""
  400.     EXIT SUB
  401.  END IF
  402.  REG %AX, &H2F00
  403.  CALL INTERRUPT &H21
  404.  DTAseg& = REG(%ES)
  405.  AttrOffset& = REG(%BX) + 21
  406.  FlNOffset& = REG(%BX) + &H1E
  407.  TimeOffset& = REG(%BX) + &H16
  408.  DateOffset& = REG(%BX) + &H18
  409.  SizeOffset& = REG(%BX) + &H1A
  410.  
  411.  FlN$ = ""
  412.  DEF SEG = DTAseg&
  413.  
  414.  DO UNTIL PEEK (FlNOffset& + N) = 0
  415.    FlN$ = FlN$ + CHR$(PEEK(FlNOffset& + N))
  416.    INCR N
  417.  LOOP
  418.  
  419.  IF (PEEK(AttrOffset&) AND 16) = 16 THEN
  420.     FlN$ = "<"+FlN$+">" '                  subdirs will come back w/ brackets
  421.  END IF
  422.  
  423.  FileSize& = CVL (PEEK$ (SizeOffset&, 4))
  424.  DateCode& =  PEEK (DateOffset&) + &H100 * PEEK (DateOffset& + 1)
  425.  TimeCode& =  PEEK (TimeOffset&) + &H100 * PEEK (TimeOffset& + 1)
  426.  DEF SEG
  427.  F$ = FlN$
  428.  
  429. END SUB
  430.  
  431. '                   ========================================
  432.  
  433.  
  434. FUNCTION DecodeDate$ (DateCode&) PUBLIC
  435.  LOCAL M, D, Y
  436.  Y = DateCode&\512
  437.  M = (DateCode& MOD 512) \ 32
  438.  D = DateCode& MOD 32
  439.  DecodeDate$ = LTRIM$ (STR$ (M)) + "-" +_
  440.                    STRING$ (1 + (D > 9), "0") + LTRIM$ (STR$ (D)) + "-" +_
  441.                                LTRIM$ (STR$ (Y + 80))
  442.  
  443. END FUNCTION '         ============================      DecodeDate$ ()
  444.  
  445.  
  446. FUNCTION DecodeTime$ (TimeCode&) PUBLIC
  447.  LOCAL H, H24, M
  448.  H24 = INT(TimeCode&\2048)
  449.  IF H24 > 12 THEN
  450.     H = H24 - 12
  451.     pm = %True
  452.  ELSE
  453.     H = H24
  454.     pm = %False
  455.  END IF
  456.  IF H = 0 THEN H = 12
  457.  M = (TimeCode&-(CLNG(H24)*2048))\32
  458.  
  459.  DecodeTime$ = STRING$ (1 + (H > 9), " ") + LTRIM$ (STR$ (H)) + ":" +_
  460.                    STRING$ (1 + (M > 9), "0") + LTRIM$ (STR$ (M)) +_
  461.                                MID$ (" pm am", pm*3+4, 3)
  462. END FUNCTION '         ============================      DecodeTime$ ()
  463.  
  464.  
  465. FUNCTION EXIST (F$) PUBLIC
  466.  
  467.  LOCAL SearchErr, FZ$
  468.  
  469.  FZ$ = F$ + CHR$(0)
  470.  REG %DS, STRSEG (FZ$)
  471.  REG %DX, STRPTR (FZ$)
  472.  REG %CX, &H17
  473.  REG %AX, &H4E00
  474.  CALL INTERRUPT &H21
  475.  SearchErr = REG(%AX)
  476.  SELECT CASE SearchErr
  477.    CASE 2, 3, 15, 18
  478.      EXIST = 0
  479.    CASE ELSE
  480.      EXIST = -1
  481.  END SELECT
  482.  DEF SEG
  483.  
  484. END Function '            ==================        EXIST ()
  485.  
  486.  
  487. FUNCTION FQFileSpec$ (A$) PUBLIC
  488.  
  489.  LOCAL CurrentDir$, CurrentDrv$             ' Of course there's a DOS function
  490.  CurrentDrv$ = GetCurrentDrive$             ' that does something like this --
  491.  CurrentDir$ = GetCurrentDir$ ("")          ' maybe exactly this! I never did
  492.                                             ' try it out. So this may be the
  493.  A$ = REMOVE$ (A$, " ")                     ' hard way!
  494.  IF INSTR (A$, ANY "^/,<>+()|"+CHR$(34)) THEN
  495.    FQFileSpec$ = "": EXIT FUNCTION
  496.  END IF
  497.  
  498.  SELECT CASE INSTR (A$, ":")
  499.    CASE 0
  500.      IF INSTR (A$, "\") THEN
  501.        A$ = CurrentDrv$ + A$
  502.      ELSE
  503.        A$ = CurrentDrv$ + CurrentDir$ +"\"+ A$
  504.      END IF
  505.      EXIT SELECT
  506.    CASE 2
  507.      IF INSTR (A$, "\") = %False THEN
  508.        CurrentDir$ = GetCurrentDir$ (LEFT$(A$,1))
  509.      END IF
  510.      EXIT SELECT
  511.    CASE ELSE
  512.      PLAY "O0 C64": FQFileSpec$ = "": EXIT FUNCTION
  513.  END SELECT
  514.  IF INSTR (A$, "\") = %False THEN
  515.    IF RIGHT$ (A$, 1) = ":" THEN
  516.      A$ = A$ + CurrentDir$ + "\"
  517.    ELSEIF CurrentDir$ = "\" THEN
  518.      A$ = LEFT$ (A$, 2) + "\" + MID$ (A$, 3)
  519.    ELSE
  520.      A$ = LEFT$ (A$, 2) + CurrentDir$ + "\" + MID$ (A$, 3)
  521.    END IF
  522.  END IF
  523.  
  524.  IF RIGHT$ (A$, 1) = "\" THEN A$ = A$ + "*.*"
  525.  
  526.  REPLACE "\\" WITH "\" IN A$
  527.  FQFileSpec$ = A$
  528.  
  529. END FUNCTION '                 =========                      FQFileSpec$
  530.  
  531.  
  532.