Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / DATABASE / DPROG131.ZIP / PROGFORM.TXT < prev next >

Wrap

Text File | 1988-08-07 | 44.3 KB | 1,915 lines

*%%OPENFROM,SYSNAME *%%IF,PRG *%%DOCUMENT,PRG,Main Program SET ESCAPE OFF SET STATUS OFF SET TALK OFF SET ECHO OFF SET BELL OFF SET HEADING OFF SET SAFETY OFF SET DEVICE TO SCREEN CLEAR *%%SETPROC PUBLIC DBVersion, UserScrn *%%DBVERSION *%%MMLOAD SELECT A USE &MainFile DO IND WITH MainFile, IndxFile, IndxExpr, "ENSURE" SET FILTER TO .T. *%%IF,PUB DO PUB *%%ENDIF *%%MMINIT CLEAR GETS MHH=MH1 P=0 DO WHILE .T. *%%MMSHOW @ 24,0 @ 2,3 SAY DTOC(DATE()) @ 2,69 SAY Time() @p+5,C GET MHH CLEAR GETS DO WHIL .T. o=0 DO WHIL o<=0 o=INKE() ENDD t=0 @p+5,C SAY MHH DO CASE CASE o=5 p=p-1 CASE o=24 p=p+1 CASE o=13 t=P+1 OTHE t=AT(UPPE(CHR(o)),VK) p=IIF(t=0,p,t-1) ENDC p=IIF(p<0,NOP,p) p=IIF(p>NOP,0,p) DO CASE CASE P=0 @ 5,C GET MH1 MHH=MH1 CASE P=1 @ 6,C GET MH2 MHH=MH2 CASE P=2 @ 7,C GET MH3 MHH=MH3 CASE P=3 @ 8,C GET MH4 MHH=MH4 CASE P=4 @ 9,C GET MH5 MHH=MH5 CASE P=5 @ 10,C GET MH6 MHH=MH6 CASE P=6 @ 11,C GET MH7 MHH=MH7 CASE P=7 @ 12,C GET MH8 MHH=MH8 CASE P=8 @ 13,C GET MH9 MHH=MH9 CASE P=9 @ 14,C GET MH10 MHH=MH10 ENDC CLEAR GETS IF t>0 MH_Function=SUBS(VK,t,1) EXIT ENDI ENDD DO CASE *%%IF,ADD CASE MH_Function="A" DO ADD LOOP *%%ENDIF *%%IF,UPD CASE MH_Function="U" IF RECCOUNT()=0 *%%IF,PRG DO WAI WITH 24, 0, "File empty, request denied. " *%%ENDIF LOOP ENDIF DO UPD LOOP *%%ENDIF *%%IF,RPT CASE MH_Function="R" DO RPT GO TOP LOOP *%%ENDIF *%%IF,MM CASE MH_Function="M" DO MM GO TOP LOOP *%%ENDIF *%%IF,LAB CASE MH_Function="L" DO LAB GO TOP LOOP *%%ENDIF *%%IF,HLP CASE MH_Function="H" DO HLP WITH 1 LOOP *%%ENDIF CASE MH_Function="P" @24,0 @24,0 SAY "Delete all marked records" STORE "N" TO MH_Ans @24,30 GET MH_Ans READ IF UPPER(MH_Ans) = "Y" PACK GO TOP ENDIF RELEASE MH_Ans LOOP CASE MH_Function="I" DO IND WITH MainFile, IndxFile, IndxExpr, "REINDEX" LOOP CASE MH_Function="Q" RELEASE MH_Function *%%IF,REL DO REL *%%ENDIF CLOSE DATABASES CLOSE PROC CLEAR QUIT *%%IF,SRT CASE MH_Function="S" DO DPSORT *%%SETPROC USE &MainFile DO IND WITH MainFile, IndxFile, IndxExpr, "ENSURE" LOOP *%%ENDIF CASE MH_Function="D" RELEASE MH_Function *%%IF,REL DO REL *%%ENDIF CLOSE DATABASES CLOSE PROC CLEAR SET ESCAPE ON SET STATUS ON SET TALK ON SET BELL ON SET HEADING ON SET SAFETY ON RETURN ENDCASE ENDDO RETURN *%%ENDIF *%%IF,PRG *%%DOCUMENT,WAI,Wait / Message routine PROCEDURE WAI PARA y, x, msg PRIV dummy dummy=" " SET INTE OFF @Y,X @Y,X SAY msg+" Press any key to continue..." GET dummy READ SET INTE ON @Y,X RETU *%%ENDIF *%%IF,PRG *%%DOCUMENT,BMU,Parameterized bar menu routine PROCEDURE BMU PARA m,s,L,R,p,C * parameters: * in: m(menustr),L(len 1 opt),R(row); * out: p (pos. in m, global for continuity), C (choice char) PRIV g,t,o,sc sc=" "+s E=LEN(M)/L-1 g=SUBS(m,p*L+1,L) @r,0 SAY m @r,p*L GET g CLEA GETS t=0 c=" " DO WHIL c=" " o=0 DO WHIL o<=0 o=INKE() ENDD t=0 DO CASE CASE o=4.OR.o=32 p=p+1 CASE o=19 p=p-1 CASE o=13 t=p+1 OTHE t=AT(UPPE(CHR(o)),s) p=IIF(t=0,p,t-1) ENDC p=IIF(p<0,E,p) p=IIF(p>E,0,p) C=SUBS(sc,t+1,1) g=SUBS(m,p*L+1,L) @r,0 SAY m @r,p*L GET g CLEA GETS ENDD RETU *%%ENDIF *%%IF,FMT *%%DOCUMENT,FMT,Screen Format File PROCEDURE FMT *%%FMT RETURN *%%ENDIF *%%IF,PUB *%%DOCUMENT,PUB,Define Public Fields PROCEDURE PUB PUBLIC Clipper *%%PUB RETURN *%%ENDIF *%%IF,CAL *%%DOCUMENT,CAL,Calculate and display Calculated fields PROCEDURE CAL PARAMETERS Updating *%%CAL RETURN *%%ENDIF *%%IF,INI *%%DOCUMENT,INI,Initialize memory fields from Init or empty PROCEDURE INI *%%INI RETURN *%%ENDIF *%%IF,STO *%%DOCUMENT,STO,Store file fields to memory variables PROCEDURE STO *%%STO RETURN *%%ENDIF *%%IF,REP *%%DOCUMENT,REP,Replace file fields with memory variables PROCEDURE REP *%%REP RETURN *%%ENDIF *%%IF,REL *%%DOCUMENT,REL,Release Memory variables PROCEDURE REL *%%REL RETURN *%%ENDIF *%%IF,ADD *%%DOCUMENT,ADD,Add New records to file PROCEDURE ADD STORE " " TO MH_Wait IF "DB3+" $ DBVersion CALL &UserScrn ELSE CLEAR DO DB3 ENDIF DO WHILE .T. *%%IF,INI DO INI *%%ENDIF *%%IF,FMT DO FMT *%%ENDIF @24,0 @24,0 SAY "Press Ctrl-W without entering data to exit" READ *%%ADD *%%IF,VAL DO VAL *%%ENDIF @24,0 APPEND BLANK *%%IF,CAL DO CAL WITH "ALL" *%%ENDIF *%%IF,REP DO REP *%%ENDIF *%%IF,PRG DO WAI WITH 24,0,"" *%%ENDIF ELSE EXIT ENDIF ENDDO RELEASE MH_Wait RETURN *%%ENDIF *%%IF,UPD *%%DOCUMENT,UPD,Search,Update,Edit,Find,Print,Examine file PROCEDURE UPD PRIVATE MH_Function, MH_Answer STORE "N" TO MH_Function STORE "N" TO MH_Answer STORE SPACE(65) TO MH_Filt IF "DB3+" $ DBVersion CALL &UserScrn ELSE CLEAR DO DB3 ENDIF DO WHILE .T. *%%IF,STO DO STO *%%ENDIF *%%IF,DIS DO DIS *%%ENDIF *%%IF,CAL DO CAL WITH "VIRTUAL" *%%ENDIF IF LEN(TRIM(MH_Filt)) = 0 @24,55 SAY " " ELSE @24,55 SAY "FILT" ENDIF IF Deleted() @24,60 SAY "DEL" ELSE @24,60 SAY " " ENDIF @24,65 SAY Ltrim(Str(RECNO()))+"/"+Ltrim(STR(RECCOUNT()))+" " MH_Lcho=0 DO BMU WITH "Next Prev Top Bot Quit Edit Set List Find Help Del ","NPTBQESLFHD",5,24,MH_Lcho,MH_Function @24,0 SAY SPACE(55) DO CASE CASE UPPER(MH_Function) = "N" IF .NOT. EOF() Skip 1 IF EOF() GO BOTT ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "P" IF .NOT. BOF() SKIP -1 IF BOF() GO TOP ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "E" *%%IF,STO DO STO *%%ENDIF *%%IF,FMT DO FMT *%%ENDIF READ *%%IF,VAL DO VAL *%%ENDIF *%%IF,CAL DO CAL WITH "ALL" *%%ENDIF *%%IF,REP DO REP *%%ENDIF LOOP CASE UPPER(MH_Function) = "T" GOTO TOP LOOP CASE UPPER(MH_Function) = "B" GOTO BOTTOM LOOP CASE UPPER(MH_Function) = "D" STORE "N" TO MH_Answer @24,0 IF DELETED() @24,0 SAY "Recall this record?" ELSE @24,0 SAY "Delete this record?" ENDIF @24,22 GET MH_Answer READ IF UPPER(MH_Answer) = "Y" IF DELETED() RECALL ELSE DELETE ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "S" STORE "N" TO MH_Answer STORE MH_Filt TO MH_FiltH @24,0 @24,0 SAY "FILTER: " @24,9 GET MH_Filt READ @24,0 IF MH_Filt <> MH_FiltH IF LEN(TRIM(MH_Filt))<>0 IF IIF(Clipper,.F.,TYPE(MH_Filt)<>"L") *%%IF,PRG DO Wai WITH 24,0,"Filter expression defective, not usable. " *%%ENDIF MH_Filt=MH_FiltH LOOP ENDIF SET FILTER TO &MH_Filt ELSE SET FILTER TO .T. ENDIF GOTO TOP IF EOF() *%%IF,PRG DO WAI WITH 24,0, "Nothing matches filter! " *%%ENDIF ENDIF ENDIF LOOP *%%IF,FND CASE UPPER(MH_Function) = "F" DO FND LOOP *%%ENDIF CASE UPPER(MH_Function) = "Q" EXIT CASE UPPER(MH_Function) = "L" *%%IF,3PLUS ON ERROR DO WAI WITH 24,0,"FIX PRINTER!!! " *%%ENDIF SET DEVICE TO PRINT *%%IF,DIS DO DIS *%%ENDIF SET DEVICE TO SCREEN *%%IF,3PLUS ON ERROR *%%ENDIF LOOP *%%IF,HLP CASE UPPER(MH_Function)="H" DO HLP WITH 2 IF "DB3+" $ DBVersion CALL &UserScrn ELSE CLEAR DO DB3 ENDIF LOOP *%%ENDIF ENDCASE ENDDO SET FILTER TO .T. RETURN *%%ENDIF *%%IF,DIS *%%DOCUMENT,DIS,Display-only Format file PROCEDURE DIS *%%DIS RETURN *%%ENDIF *%%IF,FND *%%DOCUMENT,FND,Find record by key routine PROCEDURE FND IF .NOT. Indexed *%%IF,PRG DO WAI WITH 24, 0, "Database is not indexed. Set a filter. " *%%ENDIF RETURN ENDIF PRIVATE MH_Find, MH_Answer, MH_Rec @24,0 @24,0 SAY "Enter data to find in open fields" *%%FND IF LEN(TRIM(MH_Find)) # 0 STORE RECNO() TO MH_Rec SEEK MH_Find IF EOF() GOTO MH_Rec *%%IF,PRG DO WAI WITH 24, 0, "Record Not Found. " *%%ENDIF ENDIF ENDIF @24,0 RETURN *%%ENDIF *%%IF,RPT *%%DOCUMENT,RPT,Report module PROCEDURE RPT STORE .N. TO MH_Prt STORE .Y. TO MH_Con STORE .N. TO MH_Disk STORE " " TO MH_Frm STORE ".T."+SPACE(73) TO MH_Cri STORE " " TO MH_DFname IF "DB3+"$DBVersion *%%IF,3PLUS CALL DPOUT *%%ENDIF ELSE CLEAR DO DPO ENDIF @5,22 SAY MH_Prt @6,22 SAY MH_Con @7,22 SAY MH_Disk @7,42 SAY MH_DFname @9,15 SAY MH_Frm DO WHILE .T. @5,22 GET MH_Prt PICTURE "L" @6,22 GET MH_Con PICTURE "L" @7,22 GET MH_Disk PICTURE "L" @7,42 GET MH_Dfname PICTURE "!!!!!!!!!!!!!!" @9,15 GET MH_Frm PICTURE "!!!!!!!!" READ @24,0 IF MH_Prt .AND. MH_Con @24,0 SAY "You must only specify one output device" LOOP ENDIF IF MH_Prt .AND. MH_Disk @24,0 SAY "You must only specify one output device" LOOP ENDIF IF MH_Con .AND. MH_Disk @24,0 SAY "You must only specify one output device" LOOP ENDIF IF MH_Disk .AND. MH_Dfname = " " @24,0 SAY "You must specify a disk file name" LOOP ENDIF IF MH_Frm = " " @24,0 SAY "You must enter a sort name or 'NOSORT'" LOOP ENDIF EXIT ENDDO IF MH_Frm = "NOSORT " STORE .F. TO MH_NdxL ELSE IF .NOT.(FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt)) *%%IF,PRG DO WAI WITH 24,0,"DPSORT files not found. " *%%ENDIF RETURN ENDIF SELE I USE DPSORT INDEX DPSORT SEEK MH_Frm IF EOF() *%%IF,PRG DO Wai WITH 24,0, "Sort name not on selection file (DPSORT.DBF). " *%%ENDIF SELE A RETURN ENDIF STORE SORTCRI TO MH_Cri STORE SORTNDX TO MH_NDX STORE SORTFRM TO MH_FRM STORE .F. TO MH_NdxL MH_Srt="*" SortOk=.F. DO SortChk WITH MH_Srt, MH_NdxL, SortOk IF .NOT. SortOk *%%IF,PRG DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. " *%%ENDIF RETURN ENDIF ENDIF @16,13 GET MH_Frm @19,2 GET MH_Cri READ DO WHILE LEN(TRIM(MH_Frm)) = 0 @24,0 SAY "You must specify a form for REPORTs and LABELS" @16,13 GET MH_Frm READ ENDDO @24,0 DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L") @24,0 SAY "Criteria NOT a legal expression" @19,2 GET MH_Cri READ ENDDO @24,0 STORE TRIM(MH_Frm)+".FRM" TO MH_work IF .NOT. FILE(MH_Work) *%%IF,PRG DO WAI WITH 24,0,"REPORT FORM "+TRIM(MH_Frm)+" not found. " *%%ENDIF RETURN ENDIF IF MH_NdxL @24,0 @24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . " IF MH_Cri=SPACE(76) STORE ".T."+SPACE(73) TO MH_Cri ENDIF IF RECCOUNT()>1 SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri ELSE COPY TO &MH_NDX FOR &MH_Cri ENDIF SELE J USE &MH_NDX ELSE @24,0 @24,0 SAY "Using Unsorted File" ENDIF @24,0 @24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . " DO CASE CASE MH_Con REPORT FORM &MH_Frm FOR &MH_Cri CASE MH_Prt SET CONSOLE OFF REPORT FORM &MH_Frm TO PRINT FOR &MH_Cri SET CONSOLE ON CASE MH_Disk SET CONSOLE OFF SET ALTERNATE TO &MH_Dfname SET ALTERNATE ON REPORT FORM &MH_Frm FOR &MH_Cri SET ALTERNATE OFF CLOSE ALTERNATE SET CONSOLE ON ENDCASE IF MH_NdxL USE ENDIF SELE A RETURN *%%ENDIF *%%IF,LAB *%%DOCUMENT,LAB,Label Module PROCEDURE LAB STORE .N. TO MH_Prt STORE .Y. TO MH_Con STORE .N. TO MH_Disk STORE " " TO MH_Frm STORE ".T."+SPACE(73) TO MH_Cri STORE " " TO MH_DFname IF "DB3+"$DBVersion *%%IF,3PLUS CALL DPOUT *%%ENDIF ELSE CLEAR DO DPO ENDIF @5,22 SAY MH_Prt @6,22 SAY MH_Con @7,22 SAY MH_Disk @7,42 SAY MH_DFname @9,15 SAY MH_Frm DO WHILE .T. @5,22 GET MH_Prt PICTURE "L" @6,22 GET MH_Con PICTURE "L" @7,22 GET MH_Disk PICTURE "L" @7,42 GET MH_Dfname PICTURE "!!!!!!!!!!!!!!" @9,15 GET MH_Frm PICTURE "!!!!!!!!" READ @24,0 IF MH_Prt .AND. MH_Con @24,0 SAY "You must only specify one output device" LOOP ENDIF IF MH_Prt .AND. MH_Disk @24,0 SAY "You must only specify one output device" LOOP ENDIF IF MH_Con .AND. MH_Disk @24,0 SAY "You must only specify one output device" LOOP ENDIF IF MH_Disk .AND. MH_Dfname = " " @24,0 SAY "You must specify a disk file name" LOOP ENDIF IF MH_Frm = " " @24,0 SAY "You must enter a sort name or 'NOSORT'" LOOP ENDIF EXIT ENDDO IF MH_Frm = "NOSORT " STORE .F. TO MH_NdxL ELSE IF .NOT.(FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt)) *%%IF,PRG DO WAI WITH 24,0,"DPSORT files not found. " *%%ENDIF RETURN ENDIF SELE I USE DPSORT INDEX DPSORT SEEK MH_Frm IF EOF() *%%IF,PRG DO Wai WITH 24,0,"Sort name not on selection file (DPSORT.DBF). " *%%ENDIF SELE A RETURN ENDIF STORE SORTCRI TO MH_Cri STORE SORTNDX TO MH_NDX STORE SORTFRM TO MH_FRM STORE .F. TO MH_NdxL MH_Srt="*" SortOk=.F. DO SortChk WITH MH_Srt, MH_NdxL, SortOk IF .NOT. SortOk *%%IF,PRG DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. " *%%ENDIF RETURN ENDIF ENDIF @16,13 GET MH_Frm @19,2 GET MH_Cri READ DO WHILE LEN(TRIM(MH_Frm)) = 0 @24,0 SAY "You must specify a form for REPORTs and LABELS" @16,13 GET MH_Frm READ ENDDO @24,0 DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L") @24,0 SAY "Criteria NOT a legal expression" @19,2 GET MH_Cri READ ENDDO @24,0 STORE TRIM(MH_Frm)+".LBL" TO MH_work IF .NOT. FILE(MH_Work) *%%IF,PRG DO WAI WITH 24,0,"LABEL FORM "+TRIM(MH_Frm)+" not found. " *%%ENDIF RETURN ENDIF IF MH_NdxL @24,0 @24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . " IF MH_Cri=SPACE(76) STORE ".T."+SPACE(73) TO MH_Cri ENDIF IF RECCOUNT()>1 SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri ELSE COPY TO &MH_NDX FOR &MH_Cri ENDIF SELE J USE &MH_NDX ELSE @24,0 @24,0 SAY "Using Unsorted File" ENDIF @24,0 @24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . " DO CASE CASE MH_Con LABEL FORM &MH_Frm FOR &MH_Cri CASE MH_Prt SET CONSOLE OFF LABEL FORM &MH_Frm TO PRINT FOR &MH_Cri SET CONSOLE ON CASE MH_Disk SET CONSOLE OFF SET ALTERNATE TO &MH_Dfname SET ALTERNATE ON LABEL FORM &MH_Frm FOR &MH_Cri SET ALTERNATE OFF CLOSE ALTERNATE SET CONSOLE ON ENDCASE IF MH_NdxL USE ENDIF SELE A RETURN *%%ENDIF *%%IF,MM *%%DOCUMENT,MM,Mail Merge module PROCEDURE MM STORE .N. TO MH_Prt STORE .N. TO MH_Con STORE .Y. TO MH_Disk STORE "MMWORK " TO MH_DFname STORE " " TO MH_Frm STORE "WORDSTAR" TO MH_WP STORE ".T."+SPACE(73) TO MH_Cri IF "DB3+"$DBVersion *%%IF,3PLUS CALL DPOUT *%%ENDIF ELSE CLEAR DO DPO ENDIF @11,2 SAY "Word Processor:" @7,22 SAY MH_Disk @7,42 SAY MH_DFname @9,15 SAY MH_Frm @11,19 SAY MH_WP DO WHILE .T. @7,42 GET MH_Dfname PICTURE "!!!!!!!!!!" @9,15 GET MH_Frm PICTURE "!!!!!!!!" @11,19 GET MH_WP PICTURE "!!!!!!!!" READ @24,0 IF MH_Disk .AND. MH_Dfname = " " @24,0 SAY "You must enter a disk filename" LOOP ENDIF IF MH_Frm = " " @24,0 SAY "You must enter a sort form or 'NOSORT'" LOOP ENDIF IF .NOT.(MH_WP = "WORDSTAR" .OR. MH_WP = "MSWORD ") @24,0 SAY "Current WP formats are: WORDSTAR, MSWORD" LOOP ENDIF EXIT ENDDO IF MH_Frm = "NOSORT " STORE .F. TO MH_NdxL ELSE IF .NOT. (FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt)) *%%IF,PRG DO WAI WITH 24,0,"DPSORT files not found. " *%%ENDIF RETURN ENDIF SELE I USE DPSORT INDEX DPSORT SEEK MH_Frm IF EOF() *%%IF,PRG DO WAI WITH 24,0,"Sort name not on selection file (DPSORT.DBF). " *%%ENDIF USE SELE A RETURN ENDIF STORE SORTCRI TO MH_Cri STORE SORTNDX TO MH_NDX STORE .F. TO MH_NdxL MH_Srt="*" SortOk=.F. DO SortChk WITH MH_Srt, MH_NdxL, SortOk IF .NOT. SortOk *%%IF,PRG DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. " *%%ENDIF RETURN ENDIF ENDIF @24,0 @19,2 GET MH_Cri READ DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L") @24,0 SAY "Criteria NOT a legal expression" @19,2 GET MH_Cri READ ENDDO @24,0 IF MH_NdxL @24,0 @24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . " IF MH_Cri=SPACE(76) STORE ".T."+SPACE(73) TO MH_Cri ENDIF IF RECCOUNT()>1 SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri ELSE COPY TO &MH_NDX FOR &MH_Cri ENDIF SELE J USE &MH_NDX ELSE @24,0 @24,0 SAY "Using Unsorted File" ENDIF @24,0 @24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . " IF (.NOT. MH_NdxL) .AND. (LEN(TRIM(MH_Cri)) <> 0) LOCATE FOR &MH_Cri ENDIF IF EOF() *%%IF,PRG DO WAI WITH 24,0,"No records meet criteria. " *%%ENDIF SELE A RETURN ENDIF * * Turn on output device * SET CONSOLE OFF STORE TRIM(MH_Dfname)+".DOC" TO MH_Ofn SET ALTERNATE TO &MH_Ofn SET ALTERNATE ON * * Output field header * DO CASE CASE MH_WP = "WORDSTAR" ?".OP" ?".DF "+MH_DFNAME+".DAT" ?".RV " *%%MMFIELDS ? SET ALTERNATE OFF CLOSE ALTERNATE STORE TRIM(MH_Dfname)+".DAT" TO MH_Ofn SET ALTERNATE TO &MH_Ofn SET ALTERNATE ON CASE MH_WP = "MSWORD " ? *%%MMFIELDS ENDCASE * * Output Selected data * DO WHILE .NOT. EOF() DO CASE CASE (MH_WP = "WORDSTAR") .OR. (MH_WP = "MSWORD ") ? "" *%%MMDATA ENDCASE IF MH_NdxL .OR. (LEN(TRIM(MH_Cri)) = 0) SKIP ELSE CONTINUE ENDIF ENDDO * * Finish output * SET ALTERNATE OFF CLOSE ALTERNATE SET CONSOLE ON IF MH_NdxL USE ENDIF SELE A RETURN *%%ENDIF *%%IF,VAL *%%DOCUMENT,VAL,Validate data module PROCEDURE VAL *%%VAL RETURN *%%ENDIF *%%IF,HLP *%%DOCUMENT,HLP,Give general information PROCEDURE HLP PARAMETERS What *%%HLP RETURN *%%ENDIF *%%IF,PRG *%%DOCUMENT,IND,Build/re-build Index module PROCEDURE IND PARAMETERS DataFile, IndxFile, IndxExpr, action IF .NOT. Indexed RETURN ENDIF USE &DataFile @24,0 IF .NOT. File(IndxFile) @24,0 SAY "Please wait, file is being Indexed . . . " INDEX ON &IndxExpr TO &IndxFile ELSE IF action="REINDEX" @24,0 SAY "Please wait, file is being Re-Indexed . . . " REINDEX ENDIF ENDIF SET INDEX TO &IndxFile @24,0 RETURN *%%ENDIF *%%IF,PRG*(SRT+RPT+LAB+MM) *%%DOCUMENT,SCH,Validate/Verify Sort Fields for Sort routine PROCEDURE SortChk PARAMETERS MH_Srt, MH_NdxL, SortOK PRIVATE sfld, sortf, sorto, SVar SortOK=.T. SELE I USE DPSORT INDEX DPSORT MH_Srt="" sfld=1 DO WHILE sfld<=10 sortf="SORTF"+LTRIM(STR(sfld)) sorto="SORTO"+LTRIM(STR(sfld)) SVar=TRIM(&sortf) IF &SORTF <> " " SELE A IF .NOT. TYPE(SVar)$"CDN" SELE I USE SELE A SortOK=.F. RETURN ENDIF SELE I IF LEN(MH_Srt)=0 STORE TRIM(&SORTF)+"/"+&SORTO TO MH_Srt ELSE STORE MH_Srt+", "+TRIM(&SORTF)+"/"+&SORTO TO MH_Srt ENDIF STORE .T. TO MH_NdxL ENDIF sfld=sfld+1 ENDDO USE SELE A RETURN *%%ENDIF *%%IF,~(3PLUS) *%%MAKEDB3 *%%ENDIF *%%CLOSE *%%IF,SRT*PRG *%%OPENDIRECT,DPSORT *%%DOCUMENT,PRG,Main Menu Program * database: DPSORT PRIVATE MH_Function, MH_Loop SET STATUS OFF SET TALK OFF SET ECHO OFF SET BELL OFF SET HEADING OFF SET SAFETY OFF SET DEVICE TO SCREEN SET PROCEDURE TO DPSORT SELECT I DO IND_ WITH "ENSURE" USE DPSORT INDEX DPSORT SET FILTER TO DO PUB_ STORE .T. TO MH_Loop DO WHILE MH_Loop DO CASE CASE "CLIPPER"$DBVersion *%%IF,CLIPPER CLEAR DO DPMMSRTS *%%ENDIF CASE "DB3+"$DBVersion *%%IF,3PLUS CALL DPMMSORT *%%ENDIF CASE "DB3"$DBVersion *%%IF,DB3 CLEAR DO DPMMSRTS *%%ENDIF ENDCASE STORE " " TO MH_Function @ 24,0 @ 2,3 SAY DTOC(DATE()) @ 2,69 SAY Time() @ 23,47 SAY "Choice:" @ 23,55 GET MH_Function PICT "!" READ DO CASE CASE UPPER(MH_Function)="A" DO ADD_ LOOP CASE UPPER(MH_Function)="U" IF RECCOUNT()=0 DO WAI_ WITH 24, 0, "File empty, request denied." LOOP ENDIF DO UPD_ LOOP CASE UPPER(MH_Function)="I" DO IND_ WITH "REINDEX" LOOP CASE UPPER(MH_Function)="H" DO HLP_ WITH 1 LOOP CASE UPPER(MH_Function)="P" @24,0 @24,0 SAY "Delete all marked records" PRIVATE MH_Ans STORE "N" TO MH_Ans @24,30 GET MH_Ans PICT "!" READ IF MH_Ans="Y" PACK ENDIF RELEASE MH_Ans LOOP CASE UPPER(MH_Function)="Q" DO REL_ CLOSE DATABASES CLEAR QUIT CASE UPPER(MH_Function)="D" DO REL_ CLOSE DATABASES RETURN CASE UPPER(mh_function)="R" IF Clipper DO WAI_ WITH 24, 0, "Report Create/Modify not implemented by Clipper." LOOP ENDIF STORE " " TO MH_Name @24,0 @24,0 SAY "Report Name:" @24,14 GET MH_Name READ IF MH_Name <> " " SELE A *%%IF,~(CLIPPER) MODI REPORT &MH_Name *%%ENDIF SELE I ENDIF LOOP CASE UPPER(mh_function)="L" IF Clipper DO WAI_ WITH 24, 0, "Label Create/Modify not implemented by Clipper." LOOP ENDIF STORE " " TO MH_Name @24,0 @24,0 SAY "Label Name:" @24,14 GET MH_Name READ IF MH_Name <> " " SELE A *%%IF,~(CLIPPER) MODI LABEL &MH_Name *%%ENDIF SELE I ENDIF LOOP ENDCASE ENDDO RETURN *%%DOCUMENT,IND,Build/ReBuild Index PROCEDURE IND_ PARAMETERS action SELE I USE DPSORT IF (.NOT. FILE("DPSORT"+IIF(Clipper,".NTX",".NDX"))) .OR. action="REINDEX" @24,0 @24,0 SAY "Please wait, file is being Indexed" INDEX ON SORTNAM TO DPSORT @24,0 ENDIF SET INDEX TO DPSORT RETURN *%%DOCUMENT,FMT,Screen Format file PROCEDURE FMT_ PARA Action IF action="A" @4,13 GET MA_SORTNAM PICTURE "!!!!!!!!" ENDIF @4,48 GET MA_SORTNDX PICTURE "!!!!!!!!" @4,70 GET MA_SORTFRM PICTURE "!!!!!!!!" @5,15 GET MA_SORTDES @8,2 GET MA_SORTCRI RETURN *%%DOCUMENT,PUB,Define Public Fields PROCEDURE PUB_ PUBLIC MA_SORTNAM PUBLIC MA_SORTNDX PUBLIC MA_SORTFRM PUBLIC MA_SORTDES PUBLIC MA_SORTCRI PUBLIC MA_SORTF1 PUBLIC MA_SORTO1 PUBLIC MA_SORTF2 PUBLIC MA_SORTO2 PUBLIC MA_SORTF3 PUBLIC MA_SORTO3 PUBLIC MA_SORTF4 PUBLIC MA_SORTO4 PUBLIC MA_SORTF5 PUBLIC MA_SORTO5 PUBLIC MA_SORTF6 PUBLIC MA_SORTO6 PUBLIC MA_SORTF7 PUBLIC MA_SORTO7 PUBLIC MA_SORTF8 PUBLIC MA_SORTO8 PUBLIC MA_SORTF9 PUBLIC MA_SORTO9 PUBLIC MA_SORTF10 PUBLIC MA_SORTO10 RETURN *%%DOCUMENT,CAL,Calculate and Display Calculated Fields PROCEDURE CAL_ RETURN *%%DOCUMENT,INT,Initialize Memory fields from Init or empty PROCEDURE INT_ STORE SPACE(8) TO MA_SORTNAM STORE "SORTWORK" TO MA_SORTNDX STORE SPACE(8) TO MA_SORTFRM STORE SPACE(63) TO MA_SORTDES STORE ".T."+SPACE(LEN(DPSORT->SORTCRI)-1) TO MA_SORTCRI STORE SPACE(7) TO MA_SORTF1 STORE "A" TO MA_SORTO1 STORE SPACE(7) TO MA_SORTF2 STORE "A" TO MA_SORTO2 STORE SPACE(7) TO MA_SORTF3 STORE "A" TO MA_SORTO3 STORE SPACE(7) TO MA_SORTF4 STORE "A" TO MA_SORTO4 STORE SPACE(7) TO MA_SORTF5 STORE "A" TO MA_SORTO5 STORE SPACE(7) TO MA_SORTF6 STORE "A" TO MA_SORTO6 STORE SPACE(7) TO MA_SORTF7 STORE "A" TO MA_SORTO7 STORE SPACE(7) TO MA_SORTF8 STORE "A" TO MA_SORTO8 STORE SPACE(7) TO MA_SORTF9 STORE "A" TO MA_SORTO9 STORE SPACE(7) TO MA_SORTF10 STORE "A" TO MA_SORTO10 RETURN *%%DOCUMENT,STO,Store file Fields to memory variables PROCEDURE STO_ STORE DPSORT -> SORTNAM to MA_SORTNAM STORE DPSORT -> SORTNDX to MA_SORTNDX STORE DPSORT -> SORTFRM to MA_SORTFRM STORE DPSORT -> SORTDES to MA_SORTDES STORE DPSORT -> SORTCRI to MA_SORTCRI STORE DPSORT -> SORTF1 to MA_SORTF1 STORE DPSORT -> SORTO1 to MA_SORTO1 STORE DPSORT -> SORTF2 to MA_SORTF2 STORE DPSORT -> SORTO2 to MA_SORTO2 STORE DPSORT -> SORTF3 to MA_SORTF3 STORE DPSORT -> SORTO3 to MA_SORTO3 STORE DPSORT -> SORTF4 to MA_SORTF4 STORE DPSORT -> SORTO4 to MA_SORTO4 STORE DPSORT -> SORTF5 to MA_SORTF5 STORE DPSORT -> SORTO5 to MA_SORTO5 STORE DPSORT -> SORTF6 to MA_SORTF6 STORE DPSORT -> SORTO6 to MA_SORTO6 STORE DPSORT -> SORTF7 to MA_SORTF7 STORE DPSORT -> SORTO7 to MA_SORTO7 STORE DPSORT -> SORTF8 to MA_SORTF8 STORE DPSORT -> SORTO8 to MA_SORTO8 STORE DPSORT -> SORTF9 to MA_SORTF9 STORE DPSORT -> SORTO9 to MA_SORTO9 STORE DPSORT -> SORTF10 to MA_SORTF10 STORE DPSORT -> SORTO10 to MA_SORTO10 RETURN *%%DOCUMENT,REP,Replace file Fields with memory variables PROCEDURE REP_ REPLACE DPSORT -> SORTNAM WITH MA_SORTNAM REPLACE DPSORT -> SORTNDX WITH MA_SORTNDX REPLACE DPSORT -> SORTFRM WITH MA_SORTFRM REPLACE DPSORT -> SORTDES WITH MA_SORTDES REPLACE DPSORT -> SORTCRI WITH MA_SORTCRI REPLACE DPSORT -> SORTF1 WITH MA_SORTF1 REPLACE DPSORT -> SORTO1 WITH MA_SORTO1 REPLACE DPSORT -> SORTF2 WITH MA_SORTF2 REPLACE DPSORT -> SORTO2 WITH MA_SORTO2 REPLACE DPSORT -> SORTF3 WITH MA_SORTF3 REPLACE DPSORT -> SORTO3 WITH MA_SORTO3 REPLACE DPSORT -> SORTF4 WITH MA_SORTF4 REPLACE DPSORT -> SORTO4 WITH MA_SORTO4 REPLACE DPSORT -> SORTF5 WITH MA_SORTF5 REPLACE DPSORT -> SORTO5 WITH MA_SORTO5 REPLACE DPSORT -> SORTF6 WITH MA_SORTF6 REPLACE DPSORT -> SORTO6 WITH MA_SORTO6 REPLACE DPSORT -> SORTF7 WITH MA_SORTF7 REPLACE DPSORT -> SORTO7 WITH MA_SORTO7 REPLACE DPSORT -> SORTF8 WITH MA_SORTF8 REPLACE DPSORT -> SORTO8 WITH MA_SORTO8 REPLACE DPSORT -> SORTF9 WITH MA_SORTF9 REPLACE DPSORT -> SORTO9 WITH MA_SORTO9 REPLACE DPSORT -> SORTF10 WITH MA_SORTF10 REPLACE DPSORT -> SORTO10 WITH MA_SORTO10 RETURN *%%DOCUMENT,REL,Release Memory variables PROCEDURE REL_ RELEASE MA_SORTNAM RELEASE MA_SORTNDX RELEASE MA_SORTFRM RELEASE MA_SORTDES RELEASE MA_SORTCRI RELEASE MA_SORTF1 RELEASE MA_SORTO1 RELEASE MA_SORTF2 RELEASE MA_SORTO2 RELEASE MA_SORTF3 RELEASE MA_SORTO3 RELEASE MA_SORTF4 RELEASE MA_SORTO4 RELEASE MA_SORTF5 RELEASE MA_SORTO5 RELEASE MA_SORTF6 RELEASE MA_SORTO6 RELEASE MA_SORTF7 RELEASE MA_SORTO7 RELEASE MA_SORTF8 RELEASE MA_SORTO8 RELEASE MA_SORTF9 RELEASE MA_SORTO9 RELEASE MA_SORTF10 RELEASE MA_SORTO10 RETURN *%%DOCUMENT,ADD,Add new records to file PROCEDURE ADD_ PRIVATE MH_Loop, MH_Wait STORE .T. TO MH_Loop STORE " " TO MH_Wait DO CASE CASE "CLIPPER"$DBVersion *%%IF,CLIPPER CLEAR DO DPSORTS *%%ENDIF CASE "DB3+"$DBVersion *%%IF,3PLUS CALL DPSORT *%%ENDIF CASE "DB3"$DBVersion *%%IF,DB3 CLEAR DO DPSORTS *%%ENDIF ENDCASE DO WHILE MH_Loop DO INT_ DO FMT_ WITH "A" @24,0 @24,0 SAY "Press Ctrl-W without entering data to exit" READ IF LEN(TRIM(MA_SORTNAM)) <> 0 SEEK MA_SORTNAM @ 24,0 DO WHILE .NOT. EOF() ?? CHR(7) @24,0 SAY "Sort Name is a duplicate; change it to allow the addition." @04,13 GET MA_SORTNAM PICTURE "!!!!!!!!" READ SEEK MA_SORTNAM ENDDO @ 24,0 DO VAL_ APPEND BLANK DO REP_ DO CAL_ DO WAI_ WITH 24, 0, "" ELSE STORE .F. TO MH_Loop ENDIF ENDDO RELEASE MH_Loop,MH_Wait RETURN *%%DOCUMENT,UPD,Search Update Edit Find Print Examine file PROCEDURE UPD_ PRIVATE MH_Loop, MH_Function, MH_Answer STORE .T. TO MH_Loop STORE "N" TO MH_Function STORE "N" TO MH_Answer STORE SPACE(70) TO MH_Filt STORE "Next,Previous,Top,Bottom,Quit,Help,Delete,Edit,More " TO MH_Menu1 STORE "Find,Set filter,pRint,More " TO MH_Menu2 STORE MH_Menu1 TO MH_Menu DO CASE CASE "CLIPPER"$DBVersion *%%IF,CLIPPER CLEAR DO DPSORTS *%%ENDIF CASE "DB3+"$DBVersion *%%IF,3PLUS CALL DPSORT *%%ENDIF CASE "DB3"$DBVersion *%%IF,DB3 CLEAR DO DPSORTS *%%ENDIF ENDCASE DO WHILE MH_Loop DO STO_ DO DIS_ DO CAL_ @24,0 SAY MH_Menu @24,53 GET MH_Function PICT "!" IF LEN(TRIM(MH_Filt)) = 0 @24,55 SAY " " ELSE @24,55 SAY "FILT" ENDIF IF Deleted() @24,60 SAY "DEL" ELSE @24,60 SAY " " ENDIF @24,65 SAY Ltrim(Str(RECNO()))+"/"+Ltrim(STR(RECCOUNT()))+" " READ DO CASE CASE UPPER(MH_Function) = "N" IF .NOT. EOF() Skip 1 IF EOF() GO BOTT ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "P" IF .NOT. BOF() SKIP -1 IF BOF() GO TOP ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "E" DO STO_ DO FMT_ WITH "E" READ IF READKEY()=12 .OR. READKEY()=268 LOOP ENDIF DO VAL_ DO CAL_ DO REP_ LOOP CASE UPPER(MH_Function) = "T" GOTO TOP LOOP CASE UPPER(MH_Function) = "B" GOTO BOTTOM LOOP CASE UPPER(MH_Function) = "D" STORE "N" TO MH_Answer @24,0 IF DELETED() @24,0 SAY "Recall this record?" ELSE @24,0 SAY "Delete this record?" ENDIF @24,22 GET MH_Answer READ IF UPPER(MH_Answer) = "Y" IF DELETED() RECALL ELSE DELETE ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "S" STORE "N" TO MH_Answer STORE MH_Filt TO MH_FiltH @24,0 @24,0 SAY "FILTER: " @24,9 GET MH_Filt READ @24,0 IF MH_Filt <> MH_FiltH IF LEN(TRIM(MH_Filt)) <> 0 IF IIF(Clipper,.F.,TYPE(MH_Filt)<>"L") DO WAI_ WITH 24, 0, "Filter expression defective, not usable." MH_Filt=MH_FiltH LOOP ENDIF SET FILTER TO &MH_Filt ELSE SET FILTER TO .T. ENDIF GO TOP IF EOF() DO WAI_ WITH 24, 0, "Nothing matches filter!" ENDIF ENDIF LOOP CASE UPPER(MH_Function) = "F" DO FND_ LOOP CASE UPPER(MH_Function) = "M" IF MH_Menu1 = MH_Menu STORE MH_Menu2 TO MH_Menu ELSE STORE MH_Menu1 TO MH_Menu ENDIF LOOP CASE UPPER(MH_Function) = "Q" STORE .F. TO MH_LOOP LOOP CASE UPPER(MH_Function) = "R" DO WAI_ WITH 24,0,"MAKE SURE PRINTER IS ON LINE!!!" DO CASE CASE "DB3+"$DBVersion *%%IF,3PLUS ON ERROR DO WAI_ WITH 24,0,"Fix PRINTER !!!" *%%ENDIF CASE "CLIPPER"$DBVersion *%%IF,CLIPPER DO WHILE .NOT. ISPRINTER() ?? CHR(7) DO WAI_ WITH 24,0,"Fix PRINTER !!!" ENDDO *%%ENDIF ENDCASE SET DEVICE TO PRINT DO DIS_ SET DEVICE TO SCREEN *%%IF,3PLUS IF "DB3+"$DBVersion ON ERROR ENDIF *%%ENDIF LOOP CASE UPPER(MH_Function)="H" DO HLP_ WITH 2 DO CASE CASE "CLIPPER"$DBVersion *%%IF,CLIPPER CLEAR DO DPSORTS *%%ENDIF CASE "DB3+"$DBVersion *%%IF,3PLUS CALL DPSORT *%%ENDIF CASE "DB3"$DBVersion *%%IF,DB3 CLEAR DO DPSORTS *%%ENDIF ENDCASE LOOP ENDCASE STORE "N" TO MH_Function ENDDO SET FILTER TO .T. RELEASE MH_Function,MH_Loop,MH_Answer RETURN *%%DOCUMENT,DIS,Display-only Format file PROCEDURE DIS_ @4,13 SAY MA_SORTNAM PICTURE "!!!!!!!!" @4,48 SAY MA_SORTNDX PICTURE "!!!!!!!!" @4,70 SAY MA_SORTFRM PICTURE "!!!!!!!!" @5,15 SAY MA_SORTDES @8,2 SAY MA_SORTCRI @13,30 SAY MA_SORTF1 PICTURE "!!!!!!!" @13,46 SAY MA_SORTO1 PICTURE "!" @14,30 SAY MA_SORTF2 PICTURE "!!!!!!!" @14,46 SAY MA_SORTO2 PICTURE "!" @15,30 SAY MA_SORTF3 PICTURE "!!!!!!!" @15,46 SAY MA_SORTO3 PICTURE "!" @16,30 SAY MA_SORTF4 PICTURE "!!!!!!!" @16,46 SAY MA_SORTO4 PICTURE "!" @17,30 SAY MA_SORTF5 PICTURE "!!!!!!!" @17,46 SAY MA_SORTO5 PICTURE "!" @18,30 SAY MA_SORTF6 PICTURE "!!!!!!!" @18,46 SAY MA_SORTO6 PICTURE "!" @19,30 SAY MA_SORTF7 PICTURE "!!!!!!!" @19,46 SAY MA_SORTO7 PICTURE "!" @20,30 SAY MA_SORTF8 PICTURE "!!!!!!!" @20,46 SAY MA_SORTO8 PICTURE "!" @21,30 SAY MA_SORTF9 PICTURE "!!!!!!!" @21,46 SAY MA_SORTO9 PICTURE "!" @22,30 SAY MA_SORTF10 PICTURE "!!!!!!!" @22,46 SAY MA_SORTO10 PICTURE "!" RETURN *%%DOCUMENT,FND,Find record by key routine PROCEDURE FND_ PRIVATE MH_Find,MH_Answer,MH_Rec STORE " " TO MH_Find STORE " " TO MH_Answer STORE 0 TO MH_Rec @4,13 GET MA_SORTNAM PICTURE "!!!!!!!!" @4,48 SAY MA_SORTNDX PICTURE "!!!!!!!!" @4,70 SAY MA_SORTFRM PICTURE "!!!!!!!!" @5,15 SAY MA_SORTDES @8,2 SAY MA_SORTCRI @13,30 SAY MA_SORTF1 PICTURE "!!!!!!!" @13,46 SAY MA_SORTO1 PICTURE "!" @14,30 SAY MA_SORTF2 PICTURE "!!!!!!!" @14,46 SAY MA_SORTO2 PICTURE "!" @15,30 SAY MA_SORTF3 PICTURE "!!!!!!!" @15,46 SAY MA_SORTO3 PICTURE "!" @16,30 SAY MA_SORTF4 PICTURE "!!!!!!!" @16,46 SAY MA_SORTO4 PICTURE "!" @17,30 SAY MA_SORTF5 PICTURE "!!!!!!!" @17,46 SAY MA_SORTO5 PICTURE "!" @18,30 SAY MA_SORTF6 PICTURE "!!!!!!!" @18,46 SAY MA_SORTO6 PICTURE "!" @19,30 SAY MA_SORTF7 PICTURE "!!!!!!!" @19,46 SAY MA_SORTO7 PICTURE "!" @20,30 SAY MA_SORTF8 PICTURE "!!!!!!!" @20,46 SAY MA_SORTO8 PICTURE "!" @21,30 SAY MA_SORTF9 PICTURE "!!!!!!!" @21,46 SAY MA_SORTO9 PICTURE "!" @22,30 SAY MA_SORTF10 PICTURE "!!!!!!!" @22,46 SAY MA_SORTO10 PICTURE "!" @24,0 @24,0 SAY "Enter data to search for in open fields" READ IF LEN(TRIM(MA_SORTNAM)) <> 0 STORE MA_SORTNAM TO MH_Find STORE RECNO() TO MH_Rec FIND &MH_Find IF EOF() GOTO MH_Rec DO WAI_ WITH 24, 0, "Record NOT Found! " ELSE DO WAI_ WITH 24, 0, "Record Found! " ENDIF ENDIF RELEASE MH_Find,MH_Answer,MH_Rec @24,0 RETURN *%%DOCUMENT,VAL,Validate Data module PROCEDURE VAL_ @ 24,0 SELE A DO WHILE IIF(Clipper,.F.,TYPE(MA_SORTCRI)<>"L") ?? CHR(7) @ 24,0 SAY "Sort Criteria defective; repair the expression" @ 8,2 GET MA_SORTCRI READ ENDDO @ 24,0 SELE I IF .NOT. CLIPPER SET ESCA OFF ENDIF ofs=12 sel=1 fc=10 key=0 nums="1 2 3 4 5 6 7 8 9 10" DO WHIL key<>27 FVar="MA_SORTF"+SUBS(nums,(sel-1)*2+1,2) OVar="MA_SORTO"+SUBS(nums,(sel-1)*2+1,2) @ 24,0 @ 24,0 SAY "Up, Down arrows change fields; <RETURN> = access; <Esc> = quit" @ sel+ofs,29 SAY "@" DO GetKey WITH CHR(5)+CHR(24)+CHR(13)+CHR(27),key @sel+ofs,29 SAY " " DO CASE CASE key=5 sel=sel-1 CASE key=24 sel=sel+1 CASE key=13 DO SDF WITH sel+ofs,30,46,&Fvar,&OVar ENDC sel=IIF(sel>fc,1,sel) sel=IIF(sel<1,fc,sel) ENDD SET ESCA ON @ 24,0 RETU *%%DOCUMENT,SDF,Scan and Select; (or Enter) Sort Field Names PROCEDURE SDF PARA Ln, Cl, Cl2, Fld, Ord PRIV key fld=fld+SPACE(7-LEN(fld)) Ord=Ord+SPACE(1-LEN(Ord)) key=0 DO WHILE .T. @ Ln,Cl SAY Fld @ Ln,Cl2 SAY Ord @ 24,0 @ 24,0 SAY "<SPACE> = Field Scan; <RETURN> = Field Edit <Esc> = done field" DO GetKey WITH " "+CHR(13)+CHR(27),key @ 24,0 DO CASE CASE key=27 RETURN CASE key=13 @ 24,0 SAY "Edit the fieldname; <Esc> restores original" fno=0 fldh=fld DO WHIL fno=0 @ Ln,Cl GET fld PICTURE "!!!!!!!" READ IF LEN(TRIM(fld))=0 EXIT ENDIF IF READKEY()=12.OR.READKEY()=268 fld=fldh EXIT ENDIF @ 24,55 say "CHECKING..." DO ValidFld WITH fld, fno @ 24,55 @ 24,55 say IIF(fno>0,"OK","BAD FIELD") ENDD @ Ln,Cl SAY Fld CASE key=32 @ 24,0 SAY "Arrows Scan, <RETURN> selects, <Esc> quits Scan" STOR 1 TO I,K sks=CHR(4)+CHR(19)+CHR(13)+CHR(27) SELE A DO WHILE LEN(FIELD(I))>0 @ Ln,Cl SAY " " @ Ln,Cl SAY FIELD(I) DO GetKey WITH sks,k DO CASE CASE k=13 fld=FIELD(I)+SPACE(7-LEN(FIELD(I))) EXIT CASE k=19 I=IIF(i>1,i-1,i) CASE k=4 I=IIF(LEN(FIELD(i+1))=0,i,i+1) CASE k=27 EXIT ENDC ENDDO SELE dpsort ENDCASE IF LEN(TRIM(fld))=0 Ord=" " ELSE badord=.T. @ 24,0 DO WHILE badord @ 24,0 SAY "Enter 'A' or 'D' for Ascending/Descending Sort Order" @ Ln,Cl2 GET ord PICTURE "!" READ badord=.NOT.(ord$"AD") ENDDO @ 24,0 ENDIF ENDD RETU *%%DOCUMENT,INK,Low-level keyboard-reading routine PROCEDURE GetKey PARA S,K k=INKE() DO WHIL k=0 .AND..NOT. CHR(k)$S k=INKE() ENDD RETU *%%DOCUMENT,VFD,Ensure valid Sort Field Name entry PROCEDURE ValidFld PARA fld, fno fno=0 i=1 SELE A SET EXAC ON DO WHIL LEN(FIEL(I))>0 IF TRIM(fld)=FIEL(I) fno=I EXIT ENDI I=I+1 ENDD SELE I SET EXAC OFF RETU *%%DOCUMENT,HLP,Give general help information PROCEDURE HLP_ PARAMETERS What DO CASE CASE What = 1 @0,0 SAY "Sorry, No help available" CASE What = 2 @0,0 SAY "Sorry, No help available" OTHERWISE @0,0 SAY "LOGIC ERROR IN PROGRAM" ENDCASE DO WAI_ WITH 24, 0, "" @0,0 RETURN *%%DOCUMENT,WAI,Low-level WAIT and Message-display routine PROCEDURE WAI_ PARA y,x,msg PRIV dummy dummy=" " SET INTE OFF @Y,X @Y,X SAY msg+" Press any key to continue..." GET dummy READ SET INTE ON @Y,X RETU *%%DOCUMENT,SMM,Sort/select Main Menu screen (used when LOAD/CALL unavailable) PROCEDURE DPMMSRTS @ 1,0 SAY "╔══════════════════════════════════════════════════════════════════════════════╗" @ 2,0 SAY "║ Sort/select definition Menu ║" @ 3,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢" @ 4,0 SAY "║ ║" @ 5,0 SAY "║ A - Add new definitions ║" @ 6,0 SAY "║ U - Update, Edit, Scan, Find definitions ║" @ 7,0 SAY "║ R - Create/Modify a Dbase III Report Form ║" @ 8,0 SAY "║ ║" @ 9,0 SAY "║ L - Create/Modify a Dbase III Label Form ║" @ 10,0 SAY "║ I - Rebuild the Index ║" @ 11,0 SAY "║ P - Pack the database to remove deleted definitions ║" @ 12,0 SAY "║ ║" @ 13,0 SAY "║ ║" @ 14,0 SAY "║ Q - Quit Program, return to DOS ║" @ 15,0 SAY "║ D - Return to your application ║" @ 16,0 SAY "║ ║" @ 17,0 SAY "║ ║" @ 18,0 SAY "║ Please choose one of the above options ║" @ 19,0 SAY "║ ║" @ 20,0 SAY "╚══════════════════════════════════════════════════════════════════════════════╝" @ 23,0 SAY " Choice: " RETURN *%%DOCUMENT,STS,Sort Definitions screen (used when LOAD/CALL unavailable) PROCEDURE DPSORTS @ 1,0 SAY "╔══════════════════════════════════════════════════════════════════════════════╗" @ 2,0 SAY "║ Sort/Selection Definitions ║" @ 3,0 SAY "╠══════════════════════════════════════════════════════════════════════════════╣" @ 4,0 SAY "║ Sort Name: Sorted File Name: Form Name: ║" @ 5,0 SAY "║ Description: ║" @ 6,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢" @ 7,0 SAY "║ Selection Criteria ║" @ 8,0 SAY "║ ║" @ 9,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢" @ 10,0 SAY "║ Sort Fields ║" @ 11,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢" @ 12,0 SAY "║ Field Name Order ║" @ 13,0 SAY "║ 1) ║" @ 14,0 SAY "║ 2) ║" @ 15,0 SAY "║ 3) ║" @ 16,0 SAY "║ 4) ║" @ 17,0 SAY "║ 5) ║" @ 18,0 SAY "║ 6) ║" @ 19,0 SAY "║ 7) ║" @ 20,0 SAY "║ 8) ║" @ 21,0 SAY "║ 9) ║" @ 22,0 SAY "║ 10) ║" @ 23,0 SAY "╚══════════════════════════════════════════════════════════════════════════════╝" RETURN *%%CLOSE *%%ENDIF