(Actually PBDOS code)
'PB 3.5 program for DOS to create,browse,append,edit and index DBF tables.
'Improved version of the original PB 3.5 program. Manuel Valdes - Ago.2015
'Indexing is done using a variant of Michael Mattias' code posted here
'http://www.powerbasic.com/support/pbforums/showthread.php?t=59643
COLOR 0,7
CLS
$STACK 4048
DIM CONT(10000) AS STRING*1
DIM OBJECTIVE(100) AS STRING*1
DIM FIELD_NAME$(200,11),FLN$(200),FIELD_TYPE$(200),LENGTH$(200),DECI$(200),ASTR$(255)
DIM L$(80)
SW%=1
NOREG&=0
N%=1
P&=1
GOSUB STATUS_BAR
COLOR 7,4
LOCATE 24,10:INPUT "",ARCH$
IF ARCH$="" THEN
COLOR 7,0
CLS
END
END IF
ARCH$=UCASE$(ARCH$)
IF INSTR(ARCH$,".")=0 THEN ARCH$=ARCH$+".DBF"
COLOR 0,7
OPEN ARCH$ FOR BINARY AS #1
IF LOF(1)=0 THEN
CLOSE 1
KILL ARCH$
CLS
GOSUB NEW_FILE
IF LOF(1)=0 THEN
CLOSE 1
KILL ARCH$
CLS
END
END IF
END IF
GET$ #1,4,MARK$
GET #1,4,NOREG&
GET #1,8,HEAD_LEN%
GET #1,10,REG_LEN%
K%=(HEAD_LEN%-32)\32
GET$ #1,20,TEMP$
FOR J%=1 TO K%
FLN$(J%)=""
FOR I%=1 TO 11
GET$ #1,1,FIELD_NAME$(J%,I%)
FLN$(J%)=FLN$(J%)+FIELD_NAME$(J%,I%)
NEXT
GET$ #1,1,FIELD_TYPE$(J%)
GET$ #1,4,TEMP$
GET$ #1,1,LENGTH$(J%)
GET$ #1,1,DECI$(J%)
GET$ #1,14,TEMP$
FOR I%=2 TO 11
IF FIELD_NAME$(J%,I%-1) = CHR$(0) THEN FIELD_NAME$(J%,I%) = CHR$(0)
NEXT
NEXT
J%=0
JP%=0
IF NOREG&=0 THEN
CH$=CHR$(13)
WHILE CH$=CHR$(13)
GOSUB ADD_IT
GOSUB EDIT_IT
WEND
IF CH$<>CHR$(13) THEN DECR NOREG&
SEEK #1,HEAD_LEN%+NOREG&*REG_LEN%
PUT$ #1,CHR$(26)
SEEK #1,4
PUT$ #1,MKL$(NOREG&)
END IF
N&=1
E&=1
GOSUB CLEAR_SCR
DO
IF NOREG&>0 THEN GOSUB BROWSE_IT
DO UNTIL INSTAT
LOOP
O$=UCASE$(INKEY$)
SELECT CASE O$
CASE CHR$(27)
EXIT
CASE CHR$(65) 'A_ppend
CH$=CHR$(13)
WHILE CH$=CHR$(13)
GOSUB ADD_IT
GOSUB EDIT_IT
WEND
IF CH$<>CHR$(13) THEN
DECR NOREG&
SEEK #1,HEAD_LEN%+NOREG&*REG_LEN%
PUT$ #1,CHR$(26)
SEEK #1,4
PUT$ #1,MKL$(NOREG&)
END IF
N&=1
GOSUB CLEAR_SCR
CASE CHR$(83) 'S_earch
P&=1
GOSUB RECU
GOSUB SEARCH_IT
CASE CHR$(82) 'R_epeat search
IF L%>1 THEN GOSUB SEARCH_IT
CASE CHR$(0,80)
IF E&<MIN(NOREG&,18) THEN
INCR E&
ELSE
INCR N&
END IF
CASE CHR$(71) 'G_o to record #
LOCATE 23,1
INPUT "รน Go to Record No. ",R$
N&=VAL(R$)
LOCATE 23,1
PRINT SPC(78);
CASE CHR$(0,72) 'Arrow Up
IF E&>1 THEN
DECR E&
ELSE
DECR N&
END IF
CASE CHR$(0,73) 'Page Up
N&=N&-18
CASE CHR$(0,81) 'Page Down
N&=N&+18
CASE CHR$(69) 'E_dit
GOSUB CLEAR_SCR
DO
GOSUB EDIT_IT
IF CH$=CHR$(27) THEN EXIT
LOOP
GOSUB CLEAR_SCR
'N&=1
CASE CHR$(0,77) 'Arrow Right
INCR JP%
IF JP%=K% THEN JP%=K%-1
CASE CHR$(0,75) 'Arrow Left
DECR JP%
IF JP%<0 THEN JP%=0
CASE CHR$(0,84) 'Control Arrow Left
JP%=K%-1
CASE CHR$(0,83)
JP%=0
CASE CHR$(0,71) 'First Record
N&=1
P%=1
E&=1
CASE CHR$(0,79) 'Last Record
N&=1+NOREG&-R%
E&=18
CASE CHR$(0,59)
GOSUB HELP
CASE CHR$(0,60) 'F2
GOSUB INDEX
CASE CHR$(0,61) 'Reverse Order F3
IF FLG%=1 THEN
FLG%=2
ELSEIF FLG%=2 THEN
FLG%=1
END IF
CASE CHR$(0,62) 'F4
GOSUB DELETE_RECORD
CASE CHR$(0,63) 'F5
GOSUB PACK
CASE CHR$(0,64)
CALL MENUTASK(2,2,12,K%,FLN$(),OP%)
END SELECT
IF N&>1+NOREG&-R% THEN N&=1+NOREG&-R%
IF N&<1 THEN N&=1
LOOP
CLOSE 1
IF FLG%=1 THEN CLOSE 3
COLOR 7,0
CLS
END
CLEAR_SCR:
FOR I%=1 TO 24
LOCATE I%,1:PRINT SPC(79);
NEXT
RETURN
WRITE_IT:
IF FLG%=1 THEN
GET #3,4*(A&-1),RN&
ELSEIF FLG%=2 THEN
GET #3,4*(NOREG&-A&),RN&
ELSE
RN&=A&
END IF
SEEK #1,HEAD_LEN%+(RN&-1)*REG_LEN%
DEF SEG = VARSEG(CONT(1))
ADR%=VARPTR(CONT(1))
R$=PEEK$(ADR%,REG_LEN%)
PUT$ #1,R$
RETURN
SUB FORM_INPUT(XF%,YF%,LF%)
SHARED CH$,CH1$,ASTR$()
L%=LF%
WHILE ASTR$(L%)=CHR$(32)
DECR L%
WEND
IF L%<1 THEN L%=1
PF%=L%
CH$=CHR$(32)
CH1$=CHR$(0)
DO
LOCATE YF%,XF%
FOR I%=1 TO LF%
IF I%=PF% THEN
COLOR 7,4
ELSE
COLOR 4,7
END IF
PRINT ASTR$(I%);
NEXT
DO UNTIL INSTAT
LOOP
CH$=INKEY$
IF LEN(CH$)=2 THEN
CH1$=(MID$(CH$,2,1))
IF CH1$=CHR$(75) THEN
IF PF%>1 THEN DECR PF%
ELSEIF CH1$=CHR$(77) THEN
IF PF%<LF% THEN INCR PF%
IF PF%>L% THEN INCR L%
ELSEIF CH1$=CHR$(83) THEN
FOR I%=PF% TO L%-1
ASTR$(I%)=ASTR$(I%+1)
NEXT
IF L%>=PF% THEN
ASTR$(L%)=CHR$(32)
DECR L%
END IF
END IF
ELSE
IF CH$=CHR$(8) THEN
FOR I%=PF% TO L%
ASTR$(I%-1)=ASTR$(I%)
NEXT
IF PF%>1 THEN DECR PF%
IF L%>1 THEN
ASTR$(L%)=CHR$(32)
DECR L%
END IF
ELSEIF CH$=CHR$(27) THEN
COLOR 0,7
EXIT
ELSEIF CH$=CHR$(13) THEN
'VOID
ELSEIF CH$>CHR$(30) THEN
IF L%<LF% THEN INCR L%
FOR I%=L% TO PF% STEP -1
ASTR$(I%)=ASTR$(I%-1)
NEXT
ASTR$(PF%)=CH$
LOCATE YF%,XF%+PF%
IF PF%<LF% THEN
PRINT CH$;
INCR PF%
CH$=CHR$(0)
END IF
END IF
END IF
IF CH$=CHR$(13) OR (INSTR(CHR$(72,80,73,81,119,117,60,61,62),CH1$) > 0) THEN EXIT
LOOP
COLOR 0,7
END SUB
STATUS_BAR:
LOCATE 24,1
COLOR 7,4
PRINT STRING$(80,32);
LOCATE 24,3
PRINT "File : ";ARCH$
LOCATE 24,51
PRINT "ยบ Reg. No. ";
PRINT USING "######";N&+E&-1;
PRINT "/";
PRINT USING "######";NOREG&;
PRINT " ";
COLOR 0,7
RETURN
RECU:
POREL%=1
LENGTH$(0)="0"
TEMP$=""
LOCATE 23,1
PRINT "รน Search:"
LOCATE 23,12
INPUT "",TEMP$
L%=LEN(TEMP$)
LOCATE 23,1
PRINT SPC(78);
LOCATE 23,1:PRINT "รน in Field : ";
OP%=1
CALL MENUTASK(2,2,12,K%,FLN$(),OP%)
IF FIELD_TYPE$(OP%)=CHR$(68) THEN
TEMP$=MID$(TEMP$,7,2)+MID$(TEMP$,4,2)+MID$(TEMP$,1,2)
L%=6
END IF
FOR I%=1 TO L%
OBJECTIVE(I%)=MID$(TEMP$,I%,1)
NEXT
RETURN
READ_IT:
IF FLG%=1 THEN
GET #3,4*(A&-1),RN&
ELSEIF FLG%=2 THEN
GET #3,4*(NOREG&-A&),RN&
ELSE
RN&=A&
END IF
DEF SEG=VARSEG(CONT(1))
ADR%=VARPTR(CONT(1))
SEEK #1,HEAD_LEN%+(RN&-1)*REG_LEN%
GET$ #1,REG_LEN%,R$
POKE$ ADR%,R$
RETURN
SEARCH_IT:
POREL%=1
FOR I%=1 TO OP%-1
POREL%=POREL%+ASC(LENGTH$(I%))
NEXT
POLIM%=ASC(LENGTH$(OP%))
IF OP%=0 THEN
POREL%=1
POLIM%=REG_LEN%
END IF
N&=P&
DO UNTIL Y%=1 OR N&=NOREG&
IF N&<NOREG& THEN
INCR N&
A&=(N&)
GOSUB READ_IT
END IF
COLOR 7,4
LOCATE 24,63
PRINT USING "######";N&
COLOR 0,7
H%=POREL%
Y%=0
WHILE Y%=0 AND H%<=POREL%+POLIM%
IF UCASE$(CONT(H%))=UCASE$(OBJECTIVE(1)) THEN
Y%=1
FOR J%=2 TO L%
IF UCASE$(CONT(H%+J%-1))<>UCASE$(OBJECTIVE(J%)) THEN Y%=0
NEXT
END IF
INCR H%
WEND
LOOP
IF Y%=1 THEN
BEEP
Y%=0
END IF
P&=N&
LOCATE 23,1
PRINT SPC(78)
CH$=CHR$(27)
RETURN
INICIATE_IT:
OPEN "B",#1,ARCH$
PUT$ #1,CHR$(3,0,0,0)
PUT$ #1,MKL$(NOREG&)
HEAD_LEN%=(32*K%)+33
PUT$ #1,MKI$(HEAD_LEN%)
INCR REG_LEN%
PUT$ #1,MKI$(REG_LEN%)
PUT$ #1,STRING$(20,CHR$(0))
FOR J%=1 TO K%
FOR I%=1 TO 10
PUT$ #1,FIELD_NAME$(J%,I%)
NEXT
PUT$ #1,CHR$(0)
PUT$ #1,FIELD_TYPE$(J%)
PUT$ #1,STRING$(4,0)
PUT$ #1,LENGTH$(J%)
PUT$ #1,DECI$(J%)
PUT$ #1,STRING$(14,0)
NEXT
PUT$ #1,CHR$(13,26)
CLOSE 1
RETURN
NEW_FILE:
GOSUB STATUS_BAR
PC%=1
K%=1
FOR I%=1 TO 11
FIELD_NAME$(1,I%)=CHR$(32)
NEXT
FIELD_TYPE$(1)=CHR$(32)
LENGTH$(1)=CHR$(0)
DECI$(1)=CHR$(0)
H%=0
PL%=1
R%=0
REG_LEN%=0
LOCATE 1,12:PRINT "No. Field Type Len Dec"
DO
FOR B%=1 TO 20
LOCATE B%+2,11
IF B%+H%>0 AND B%+H%<=K% THEN
PRINT USING "###";B%+H%;
PRINT " ";
FOR I%=1 TO 10
PRINT FIELD_NAME$(B%+H%,I%);
NEXT
PRINT " ";FIELD_TYPE$(B%+H%);" ";
PRINT USING "###";ASC(LENGTH$(B%+H%));
PRINT " ";
PRINT USING "##";ASC(DECI$(B%+H%));
PRINT " ";
COLOR 0,7
END IF
NEXT
SELECT CASE PC%
CASE 1
FOR U%=1 TO 10
ASTR$(U%)=FIELD_NAME$(PL%+H%,U%)
NEXT
CALL FORM_INPUT(16,PL%+2,10)
FOR U%=1 TO 10
FIELD_NAME$(PL%+H%,U%)=UCASE$(ASTR$(U%))
NEXT
CASE 2
IF FIELD_TYPE$(PL%+H%)>CHR$(32) THEN
ASTR$(1)=FIELD_TYPE$(PL%+H%)
ELSE
ASTR$(1)=CHR$(32)
END IF
CALL FORM_INPUT(29,PL%+2,1)
IF ASTR$(1)=CHR$(32) THEN ASTR$(1)=CHR$(67)
FIELD_TYPE$(PL%+H%)=UCASE$(ASTR$(1))
CASE 3
IF LENGTH$(PL%+H%)> CHR$(0) THEN
ASTR$(1)=MID$(STR$(ASC(LENGTH$(PL%+H%))),2,1)
ASTR$(2)=MID$(STR$(ASC(LENGTH$(PL%+H%))),3,1)
ELSE
ASTR$(1)=CHR$(32)
ASTR$(2)=CHR$(32)
END IF
CALL FORM_INPUT(34,PL%+2,2)
LENGTH$(PL%+H%)=CHR$(VAL(ASTR$(1)+ASTR$(2)))
CASE 4
IF DECI$(PL%+H%)>CHR$(0) THEN
ASTR$(1)=MID$(STR$(ASC(DECI$(PL%+H%))),2,1)
ELSE
ASTR$(1)=CHR$(32)
END IF
CALL FORM_INPUT(39,PL%+2,1)
DECI$(PL%+H%)=CHR$(VAL(ASTR$(1)))
END SELECT
IF CH1$ = CHR$(117) THEN EXIT LOOP
IF CH1$ = CHR$(80) OR CH$ = CHR$(13) THEN
IF PC%<4 THEN
INCR PC%
ELSE
PC%=1
IF PL%<20 THEN
INCR PL%
ELSE
INCR H%
END IF
END IF
END IF
IF CH$ = CHR$(13) AND PL% + H% > K% THEN
IF LENGTH$(K%) > CHR$(0) AND K% < 100 THEN INCR K%
FOR D%=1 TO 11
FIELD_NAME$(PL%+H%,D%) = CHR$(32)
NEXT
FIELD_TYPE$(PL%+H%)=CHR$(32)
LENGTH$(PL%+H%)=CHR$(0)
DECI$(PL%+H%)=CHR$(0)
END IF
IF CH1$ = CHR$(75) THEN
IF PC% = 1 THEN
PC% = 4
ELSE
DECR PC%
END IF
END IF
IF CH1$ = CHR$(72) THEN
IF PL% > 1 THEN
DECR PL%
ELSE
DECR H%
END IF
END IF
IF PL% > K% THEN PL% = K%
IF H% < 0 THEN H% = 0
IF H% > K% - 20 AND PL% = 20 THEN H% = K% - 20
LOOP
IF LENGTH$(K%) = CHR$(0) THEN DECR K%
FOR I% = 1 TO K%
REG_LEN% = REG_LEN% + ASC(LENGTH$(I%))
NEXT
IF REG_LEN% > 0 THEN GOSUB INICIATE_IT
OPEN "B",#1,ARCH$
RETURN
BROWSE_IT:
COLOR 7,0
POSI%=0
FOR H%=1 TO JP%
POSI%=POSI%+ASC(LENGTH$(H%))
NEXT
POREL%=POSI%
POLIM%=76
IF POREL%+POLIM%>REG_LEN% THEN POLIM%=REG_LEN%-POREL%
LIN$="รรรรรรร"
J%=JP%
PL%=7
R%=18
DO UNTIL J%=K% OR PL%>=79
INCR J%
PC%=0
LIN$=LIN$+CHR$(194)
INCR PL%
WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
INCR PC%
INCR PL%
LIN$=LIN$+CHR$(196)
WEND
LOOP
IF J%=K% THEN 'PRINT CHR$(191)+STRING$(79-PL%,32)
LIN$=LIN$+CHR$(191)+SPACE$(76)
END IF
LOCATE 1,1
COLOR 0,7
PRINT LEFT$(LIN$,79)
LIN$="ยณ Reg. "
J%=JP%
PL%=6
DO UNTIL J%=K% OR PL%>=79
INCR J%
PC%=0
LIN$=LIN$+CHR$(179)
INCR PL%
DO UNTIL FIELD_NAME$(J%,PC%)=CHR$(0) OR PC%=ASC(LENGTH$(J%)) OR PL%>=78
INCR PL%
INCR PC%
LIN$=LIN$+FIELD_NAME$(J%,PC%)
LOOP
WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
INCR PC%
INCR PL%
LIN$=LIN$+CHR$(32)
WEND
LOOP
IF J%=K% AND PL%<78 THEN LIN$=LIN$+CHR$(179)+SPACE$(76)
LOCATE 2,1
PRINT LEFT$(LIN$,79)
LIN$="รรรรรรร"
PL%=7
J%=JP%
DO UNTIL J%=K% OR PL%>=79
INCR J%
PC%=0
LIN$=LIN$+CHR$(197)
INCR PL%
WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
INCR PC%
INCR PL%
LIN$=LIN$+CHR$(196)
WEND
LOOP
IF J%=K% THEN LIN$=LIN$+CHR$(180)+SPACE$(76)
LOCATE 3,1
PRINT LEFT$(LIN$,79)
IF R%>NOREG& THEN R%=NOREG&
FOR B%=1 TO R%
A&=(B%+N&-1)
IF A&<=NOREG& THEN GOSUB READ_IT
IF CONT(1)=CHR$(42) THEN
BG%=14
ELSE
BG%=7
END IF
IF B%=E& THEN
COLOR BG%,4
ELSE
COLOR 0,BG%
END IF
LIN$=CHR$(179)+USING$("######",A&)
I%=POREL%+1
J%=JP%
PL%=7
DO UNTIL J%=K% OR PL%>=79
INCR J%
FEC$=""
PC%=0
LIN$=LIN$+CHR$(179)
INCR PL%
DO UNTIL PC%=ASC(LENGTH$(J%)) OR PL%>=79
INCR I%
INCR PC%
IF FIELD_TYPE$(J%)=CHR$(68) THEN
FEC$=FEC$+CONT(I%)
ELSE
LIN$=LIN$+CONT(I%)
INCR PL%
END IF
LOOP
IF FIELD_TYPE$(J%)=CHR$(68) THEN LIN$=LIN$+MID$(FEC$,7,2)+"/"+MID$(FEC$,5,2)+"/"+MID$(FEC$,3,2)
LOOP
IF J%=K% THEN LIN$=LIN$+CHR$(179)+SPACE$(76)
LOCATE B%+3
PRINT LEFT$(LIN$,79)
NEXT
COLOR 0,7
LIN$="รรรรรรร"
J%=JP%
PL%=7
DO UNTIL J%=K% OR PL%>=79
INCR J%
PC%=0
LIN$=LIN$+CHR$(193)
INCR PL%
WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
INCR PC%
INCR PL%
LIN$=LIN$+CHR$(196)
WEND
LOOP
IF J%=K% THEN LIN$=LIN$+CHR$(217)+SPACE$(76)
LOCATE B%+3,1
PRINT LEFT$(LIN$,79)
GOSUB STATUS_BAR
RETURN
ADD_IT:
SEEK #1,HEAD_LEN%+NOREG&*REG_LEN%
PUT$ #1,STRING$(REG_LEN%,32)+CHR$(26)
INCR NOREG&
SEEK #1,4
PUT$ #1,MKL$(NOREG&)
N&=NOREG&
E&=1
RETURN
EDIT_IT:
POREL%=0
POLIM%=REG_LEN%
A&=(N&+E&-1)
GOSUB READ_IT
H%=0
POSI%=2
PL%=1
R%=0
DO
FOR B%=1 TO 22
LOCATE B%,1:PRINT SPC(79);
IF (B%+H%>0) AND (B%+H%<=K%) THEN
LOCATE B%,1
FEC$=""
PRINT USING "###";B%+H%;
PRINT " ";
FOR I%=1 TO 10
PRINT FIELD_NAME$(B%+H%,I%);
NEXT
PRINT " ";FIELD_TYPE$(B%+H%);
PRINT USING "###";ASC(LENGTH$(B%+H%));
PRINT USING "##";ASC(DECI$(B%+H%));
PRINT " ";
'IF PL%=B% THEN COLOR 7,0
FOR I%=POSI% TO POSI%+ASC(LENGTH$(B%+H%))-1
IF FIELD_TYPE$(B%+H%)=CHR$(68) THEN
FEC$=FEC$+CONT(I%)
ELSE
PRINT CONT(I%);
END IF
NEXT
IF FIELD_TYPE$(B%+H%)=CHR$(68) THEN PRINT MID$(FEC$,7,2)+"/"+MID$(FEC$,5,2)+"/"+MID$(FEC$,3,2);
POSI%=POSI%+ASC(LENGTH$(B%+H%))
COLOR 0,7
ELSE
END IF
NEXT
GOSUB STATUS_BAR
PR%=2
FOR U%=1 TO PL%+H%-1
PR%=PR%+ASC(LENGTH$(U%))
NEXT
PE%=PR%+ASC(LENGTH$(PL%+H%))
D%=0
FOR U%=PR% TO PE%
INCR D%
ASTR$(D%)=CONT(U%)
NEXT
CALL FORM_INPUT(23,PL%,ASC(LENGTH$(PL%+H%)))
IF FIELD_TYPE$(PL%+H%)=CHR$(78) THEN
D%=PE%-PR%
FOR U%=PE%-PR% TO 1 STEP -1
IF CH1$=CHR$(83) THEN CONT(PR%+U%-1)=CHR$(32)
IF ASTR$(U%)<>CHR$(32) THEN
DECR D%
CONT(PR%+D%)=ASTR$(U%)
END IF
NEXT
ELSE
D%=0
FOR U%=PR% TO PE% - 1
INCR D%
CONT(U%)=ASTR$(D%)
NEXT
END IF
IF CH$=CHR$(13) OR CH$=CHR$(0,83) THEN
A&=N&+E&-1
GOSUB WRITE_IT
IF H%+PL%=K% THEN EXIT LOOP
END IF
IF CH$=CHR$(0,80) OR CH$=CHR$(13) THEN
IF PL%<22 THEN
INCR PL%
ELSE
INCR H%
END IF
END IF
IF CH$=CHR$(0,72) THEN
IF PL%>1 THEN
DECR PL%
ELSE
DECR H%
END IF
END IF
IF CH$=CHR$(0,81) THEN
IF E&<MIN(NOREG&,19) THEN
INCR E&
ELSE
INCR N&
END IF
IF N&>NOREG&-19 THEN N&=NOREG&-19
A&=N&+E&-1
GOSUB READ_IT
END IF
IF CH$=CHR$(0,73) THEN
IF E&>1 THEN
DECR E&
ELSE
DECR N&
END IF
IF N&<1 THEN N&=1
A&=N&+E&-1
GOSUB READ_IT
END IF
IF PL%>K% THEN
PL%=1
CH$=CHR$(0,117)
END IF
IF H%<0 THEN H%=0
IF H%>K%-22 AND PL%=22 THEN H%=K%-22
POSI%=2
FOR B%=1 TO H%
POSI%=POSI%+ASC(LENGTH$(B%))
NEXT
IF CH$=CHR$(0,117) OR CH$=CHR$(27) THEN EXIT
LOOP
RETURN
SUB MENUTASK(YS%,XS%,AM%,NO%,MTR$(),OP%)
IP%=1
OP%=0
CALL WIN(YS%,XS%,AM%+1,MIN(NO%,12),1)
L$=""
COLOR 1,7
LOCATE 23,2:PRINT SPC(78)
DO
COLOR 15,11
FOR G%=1 TO MIN(NO%,12)
LOCATE YS%+G%,XS%+1:PRINT CHR$(32);
IF IP%=G% THEN
COLOR 4,15
ELSE
COLOR 15,11
END IF
PRINT CHR$(32)+LEFT$(MTR$(G%+OP%)+STRING$(AM%,32),AM%);
COLOR 15,11
PRINT CHR$(32);
NEXT
DO UNTIL INSTAT
LOOP
O$=INKEY$
SELECT CASE O$
CASE CHR$(27)
OP%=0
EXIT LOOP
CASE CHR$(0,80)
IF IP%<MIN(NO%,12) THEN
INCR IP%
ELSE
IF OP%<NO%-MIN(NO%,12) THEN INCR OP%
END IF
CASE CHR$(0,72)
IF IP%>1 THEN
DECR IP%
ELSE
IF OP%>0 THEN DECR OP%
END IF
CASE CHR$(0,81)
OP%=OP%+MIN(NO%,12)
IP%=MIN(NO%,12)
CASE CHR$(0,73)
OP%=OP%-MIN(NO%,12)
IF OP%<0 THEN OP%=0
IP%=1
CASE CHR$(0,79)
OP%=NO%-MIN(NO%,12)
IP%=MIN(NO%,12)
CASE CHR$(0,71)
IP%=1
OP%=0
CASE CHR$(13)
OP%=IP%+OP%
EXIT LOOP
END SELECT
IF OP%>NO%-MIN(NO%,12) THEN OP%=NO%-MIN(NO%,12)
IF IP%<1 THEN
IP%=1
IF OP%>NO%-1 THEN OP%=NO%-1
END IF
LOOP
CALL WIN(YS%,XS%,AM%+1,MIN(NO%,12),0)
END SUB
SUB WIN(YS%,XS%,AM%,NO%,P%)
SHARED L$()
IF P%=1 THEN
FOR F%=YS% TO YS%+NO%+2
L$=""
FOR V%=XS%-1 TO XS%+AM%+3
L$=L$+CHR$(SCREEN(F%,V%))
NEXT
L$(F%)=L$
NEXT
COLOR 15,11
LOCATE YS%,XS%:PRINT CHR$(218);STRING$(AM%+2,196);CHR$(191);
LOCATE YS%+NO%+1,XS%:PRINT CHR$(192);STRING$(AM%+2,196);CHR$(217);
FOR G%=1 TO NO%
LOCATE YS%+G%,XS%:PRINT CHR$(179)+STRING$(AM%+2,32)+CHR$(179);
NEXT
ELSE
COLOR 0,7
FOR V%=YS% TO YS%+NO%+2
LOCATE V%,XS%-1
PRINT L$(V%);
NEXT
END IF
END SUB
PACK:
CLOSE 1
OPEN "TMPDBF.BIN" FOR BINARY SHARED AS #1
CLOSE 1
KILL "TMPDBF.BIN"
P&=0
NAME ARCH$ AS "TMPDBF.BIN"
OPEN "TMPDBF.BIN" FOR BINARY SHARED AS #1
IF LOF(1)>0 THEN
OPEN ARCH$ FOR BINARY SHARED AS #2
GET$ #1,HEAD_LEN%,L$
PUT$ #2,L$
FOR A&=1 TO NOREG&
SEEK #1,HEAD_LEN%+(A&-1)*REG_LEN%
GET$ #1,REG_LEN%,L$
IF LEFT$(L$,1)<>CHR$(42) THEN
INCR P&
PUT$ #2,L$
END IF
NEXT
NOREG&=P&
SETEOF #2
SEEK #2,4
PUT$ #2,MKL$(NOREG&)
CLOSE 1
CLOSE 2
END IF
OPEN ARCH$ FOR BINARY SHARED AS #1
RETURN
DELETE_RECORD:
A&=N&+E&-1
SEEK #1,HEAD_LEN%+(A&-1)*REG_LEN%
GET$ #1,1,L$
IF L$<>CHR$(42) THEN
L$=CHR$(42)
ELSEIF L$=CHR$(42) THEN
L$=CHR$(32)
END IF
SEEK #1,HEAD_LEN%+(A&-1)*REG_LEN%
PUT$ #1,L$
RETURN
INDEX:
CALL MENUTASK(2,2,11,K%,FLN$(),OP%)
IF OP%>0 THEN
RELPOS%=1
FOR J&=1 TO OP%-1
RELPOS%=RELPOS%+ASC(LENGTH$(J&))
NEXT
OFS%=HEAD_LEN%+RELPOS%
LR%=ASC(LENGTH$(OP%))
FLG%=0
CLOSE 3
OPEN LEFT$(REMOVE$(ARCH$,".DBF"),5)+RIGHT$(USING$("####",1000+OP%),3)+".NDX" FOR BINARY AS #3
IF LOF(3)<>4*NOREG& THEN
FOR I&=1 TO NOREG&
PUT$ #3,MKL$(I&)
NEXT
SETEOF 3
CALL QSortExp(1,NOREG&)
END IF
FLG%=1
END IF
RETURN
SUB QSortExp(Head&,Tail&)
H&=Head&
T&=Tail&
P$=Pivot$((Head&+Tail&)\2)
DO
DO WHILE Pivot$(H&)<P$ AND H&<Tail&
INCR H&
LOOP
DO WHILE Pivot$(T&)>P$ AND T&>Head&
DECR T&
LOOP
IF H&<=T& THEN
CALL SWAPITEMS(H&,T&)
INCR H&
DECR T&
END IF
LOOP WHILE H&<=T&
IF Head& < T& THEN
CALL QSortExp(Head&,T&)
END IF
IF H& < Tail& THEN
CALL QSortExp(H&, Tail&)
END IF
END SUB
FUNCTION Pivot$(RecNum&)
SHARED REG_LEN%,OFS%,LR%
GET #3,4*(RecNum&-1),RN&
SEEK #1,OFS%+(RN&-1)*REG_LEN%
GET$ #1,LR%,I$
Pivot$=I$
END FUNCTION
SUB SWAPITEMS(I&,J&)
GET #3,4*(I&-1),C&
GET #3,4*(J&-1),D&
PUT #3,4*(I&-1),D&
PUT #3,4*(J&-1),C&
END SUB
HELP:
CALL WIN(4,4,60,19,1)
LOCATE 6,7:PRINT "F2 - Indexes on a field content"
LOCATE 8,7:PRINT "F3 - Reverses order"
LOCATE 10,7:PRINT "F4 - Deletes the current record. (Marks it to be erased)"
LOCATE 12,7:PRINT "F5 - Pack. Erases marked records"
LOCATE 14,7:PRINT "E - Switch to the Edit Mode"
LOCATE 16,7:PRINT "A - Switch to the Append Mode"
LOCATE 18,7:PRINT "S - Search on a selected field, or on the whole records"
LOCATE 20,7:PRINT "R - Continue Searching"
LOCATE 22,7:PRINT "G - Goes to Record Number"
DO UNTIL INSTAT
LOOP
O$=INKEY$
CALL WIN(4,4,60,19,0)
RETURN