Black Box 4

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

/ Black Box 4 / BlackBox.cdr / dbase / buildmdx.arj / BUILDMDX.PRG next >

Wrap

Text File | 1991-07-05 | 37.1 KB | 1,312 lines

*:********************************************************************* *: *: Program: BUILDMDX.PRG *: *: System: View DBF Structure and Recreate indexes *: Author: Gerald J. Fay M.D. *: Copyright (c) 1991, Gerald J. Fay M.D. *: Last modified: 06/21/91 20:33 *: *: Procs & Fncts: M_CHOICE *: : TEMPFILE() *: : CHECKFOR *: : SHADOWNG *: : DELREIN *: : LOCK_REP *: : R_INDEX *: : CHK_FILE *: : PRINTDBF *: : PHEADER *: : ENDPAGE *: : TAGBLD *: : EMPTY() *: : MYDATE() *: : ERR_OUT *: : CHECKDBF() *: : CENTER() *: *: Uses: INDTEMP.DBF *: : MTEMP.DBF (Temporary file created from indtemp and Tempfile()) *: : MDBF (The Selected DBF file) *: : DEFINIT.DBF (Dbase file which stores Tag name and expression *: : CONDIT.DBF (Dbase file which stores Conditional index *: Other Files: HOLDIND.TXT Text file created from LIST STATUS *: *: Documented 06/21/91 at 20:39 SNAP! version 4.02i *:********************************************************************* CLEAR SET TALK OFF SET STATUS OFF SET CURSOR OFF ON ESCAPE *ON ERROR DO err_out WITH MDIR,ERROR(),lineno() _PLINENO=0 mpage=1 l_ookmore=.T. &&Variable for main DO WHILE Routine mlineno=1 &&Variable to store _plineno STORE SPACE(1) TO gen1,gen2,gen3 MDIR=SET("DIRECTORY") gen1=GETENV("DBHEAP") &&Checking Dbheap IF EMPTY(gen1) gen1="50" ENDIF &&Searching for Temp Directory gen2=GETENV("DBTMP") IF EMPTY(gen2) gen2=GETENV("TMP") IF EMPTY(gen2) gen2=MDIR ENDIF ENDIF STORE LEN(gen2) TO m_len dskspace=DISKSPACE()/1000000 @9,11 FILL TO 15,71 COLOR /N @8,10 FILL TO 14,70 COLOR /W @1,1 FILL TO 4,m_len+23 COLOR N/N @2,2 SAY "Dbheap is set at: "+gen1 COLOR W+/N @3,2 SAY "Temporary Directory: "+gen2 COLOR W+/N @9,15 SAY "This Computer is Running: "+VERSION() COLOR N/W @10,20 SAY "Operating System: "+OS() COLOR N/W @11,10 TO 11,70 DOUBLE COLOR R/W @12,15 SAY "Available Diskspace is: "+LTRIM(STR(dskspace,5,1))+" MegaBytes" COLOR B/W @13,20 SAY "Available Memory is: "+LTRIM(STR(MEMORY(),3))+ " K" COLOR B/W @ 20,25 SAY "Look-up Database file Y/N? " GET l_ookmore PICTURE "Y" ERROR "Enter Y or N only" COLOR GR+/B,R/W READ IF l_ookmore=.F. CLEAR SET CURSOR ON RETURN ENDIF again=.F. &&Variable to release store TAGLIST ARRAY for new lookup DEFINE POPUP lookfile FROM 1,30 TO 21,45 PROMPT Files LIKE *.dbf; MESSAGE "Please Select File from List by Pressing "+CHR(17)+CHR(196)+CHR(217)+" on File" ON SELECTION POPUP lookfile DEACTIVATE POPUP DEFINE POPUP c_hoser FROM 9,24 TO 17,59; MESSAGE "Please Select with "+CHR(17)+CHR(196)+CHR(217) DEFINE BAR 1 OF c_hoser PROMPT " SELECT OPTION ON FILE" SKIP DEFINE BAR 2 OF c_hoser PROMPT "----------------------------------" SKIP DEFINE BAR 3 OF c_hoser PROMPT " Print DBF structure and Tags" DEFINE BAR 4 OF c_hoser PROMPT " Reindex file" DEFINE BAR 5 OF c_hoser PROMPT " Delete and Recreate Index file" DEFINE BAR 6 OF c_hoser PROMPT " View another database" DEFINE BAR 7 OF c_hoser PROMPT " Clear and Return to Mainprogram" ON SELECTION POPUP c_hoser DO m_choice WITH mdbf,l_fldnum DEFINE WINDOW indexer FROM 17,10 TO 23,70 COLOR N/W,,GR+/RB DO WHILE l_ookmore=.T. MDBF=SPACE(30) CLEAR IF again RELEASE taglist RELEASE condit again=.F. ENDIF @ 2,31 FILL TO 22,46 COLOR /N ACTIVATE POPUP lookfile IF LASTKEY()=27 EXIT ENDIF STORE PROMPT() TO MDBF CLEAR IF CHECKDBF(MDBF,MDIR)=.T. && Checks to see if Selected file is @10,11 FILL TO 15,71 COLOR /N && DEFINIT.DBF or CONDIT.DBF @9,10 FILL TO 14,70 COLOR /W @11,CENTER(MDBF,80) SAY MDBF COLOR R/W @12,19 SAY "Sorry this file is required for this program" COLOR B/W @14,45 SAY "Press any key to exit" COLOR N/W STORE INKEY(0) TO it CLEAR l_ookmore=.T. LOOP ENDIF @12,34 fill to 14,48 color /n @11,33 fill to 13,47 color /w @ 12,35 SAY "Please Wait" COLOR R/W mtemp=tempfile(GEN2) COPY FILE indtemp.dbf TO &mtemp SELECT A USE (mdbf) SET CONSOLE OFF LIST STATUS TO holdind.txt IF MDIR="DONE" l_ookmore=.F. LOOP ENDIF SELECT B USE (mtemp) APPEND FROM holdind.txt TYPE DELIMITED ERASE holdind.txt DECLARE condit[20,2] && Hold up to 20 conditional index tags GO TOP m_keyer=1 condition=.F. && Marker for Conditional Index in Index TAG (FALSE is Default) DO WHILE AT("File search path:",hold)=0 .AND. .NOT. EOF() m_mhold=AT("For:",hold) IF m_mhold>0 m_thold=AT("TAG:",hold) m_khold=AT("Key:",hold) m_thold=m_thold+9 m_tagname=LTRIM(SUBSTR(hold,m_thold,m_khold-m_thold)) STORE .T. TO condition m_mhold1=LTRIM(SUBSTR(hold,m_mhold+4,20)) m_mhold1=TRIM(m_mhold1) condit[M_keyer,1]=TRIM(m_tagname) condit[M_keyer,2]=TRIM(m_mhold1) m_keyer=m_keyer+1 SKIP ENDIF SKIP ENDDO SELECT A USE IN B ERASE (mtemp) RELEASE ALL LIKE m_* SET CONSOLE ON CLEAR @9,11 FILL TO 15,71 COLOR /N @8,10 FILL TO 14,70 COLOR /W @ 9,15 SAY "The Current Database File Is: "+DBF() COLOR B/W @ 10,20 SAY "The File Contains: "+LTRIM(STR(RECCOUNT(), 10))+ " RECORDS." COLOR N/W @ 11,20 SAY "The File Was Last Updated On: "+CDOW(LUPDATE())+", " +DTOC(LUPDATE()) COLOR N/W @ 12,20 SAY "Each Record Contains "+LTRIM(STR(RECSIZE(),10))+" CHARACTERS" COLOR N/W @ 13,15 SAY "Press Any Key To See Defined Fields Or <Esc> TO Exit" COLOR R/W STORE INKEY(0) TO it IF LASTKEY()= 27 CLEAR @ 12,25 SAY "Look-up another file Y/N? " GET l_ookmore PICTURE "Y" ERROR "Enter Y or N only" COLOR GR+/B,R/W READ LOOP ENDIF DECLARE taglist[42,2] N = 1 DO WHILE LEN(TRIM(TAG(N))) <> 0 taglist[n,1] = TAG(N) taglist[n,2] = KEY(N) IF TRIM(taglist[n,1]) = TRIM(ORDER()) ln_ordno = N ENDIF && TRIM(TAGLIST[n]) = TRIM(ORDER()) N = N + 1 ENDDO && TAG(n) <> "" l_fldnum=1 DO WHILE ""<>FIELD(l_fldnum) l_fldnum=l_fldnum+1 ENDDO l_fldnum=l_fldnum-1 CLEAR @2,3 FILL TO 23,78 COLOR /N @1,2 FILL TO 22,77 COLOR /W fieldnum=1 LINE=3 DO WHILE fieldnum<=l_fldnum @ 1,4 SAY TRIM(DBF())+" Contains The Following Fields:" COLOR B/W @ 2,5 SAY " Name Type Length" COLOR R/W x_tt=FIELD(fieldnum) @LINE,4 SAY "FIELD # "+STR(fieldnum,2) + " "+FIELD(fieldnum) COLOR N/W DO CASE CASE TYPE(FIELD(fieldnum))="C" fieldtype="CHARACTER" x_te=LEN(&x_tt) x_tx=STR(x_te,3) CASE TYPE(FIELD(fieldnum))="N" .OR. TYPE(FIELD(fieldnum))="F" fieldtype="NUMERIC" x_tf=TRANSFORM(&x_tt,"@9") x_tg=LEN(x_tf) x_tp=AT(".",x_tf) x_ty=x_tg-x_tp x_tx=STR(x_tg,3) IF x_tp>0 x_tx=x_tx +" Decimal " +LTRIM(STR(x_ty)) ENDIF CASE TYPE(FIELD(fieldnum))="D" fieldtype="DATE" x_tx=" 8" CASE TYPE(FIELD(fieldnum))="L" fieldtype="LOGICAL" x_tx=" 1" CASE TYPE(FIELD(fieldnum))="M" fieldtype="MEMO" x_tx="64K" ENDCASE @ LINE,39 SAY fieldtype COLOR N/W @ LINE,60 SAY TRIM(x_tx) COLOR N/W fieldnum=fieldnum+1 LINE=LINE+1 IF LINE>19 .AND. l_fldnum/fieldnum>1 @LINE+1,4 SAY "Press any key to see more fields" COLOR R/W STORE INKEY(0) TO it @ 3,2 FILL TO 22,77 COLOR W/W LINE=3 ENDIF RELEASE ALL LIKE x_t* ENDDO @LINE+1,4 SAY "Finished viewing fields....Press any key to view index tags" COLOR R/W LINE=LINE+3 STORE INKEY(0) TO it IF LINE>=18 @ 1,2 FILL TO 22,77 COLOR W/W LINE=2 X=1 ELSE X=LINE+1 LINE=LINE+1 ENDIF IF TYPE("taglist[1,1]")="L" @X,20 SAY "No tags noted on: "+dbf() color N/W @LINE+1,4 SAY "....Press any key to Continue" COLOR R/W ELSE @X,5 SAY "The following index tags are noted on: "+DBF() COLOR B/W @ LINE+1,3 SAY " Tag Name Expression For:" COLOR R/W LINE=LINE+2 m=1 DO WHILE TYPE("TAGLIST[M,1]")#"L" forx=SPACE(30) &&stores conditional expression IF condition=.T. DO checkfor WITH m,forx ENDIF @ LINE,5 SAY taglist[M,1] COLOR N/W @ LINE,22 SAY taglist[M,2] COLOR N/W IF condition=.T. @ LINE,54 SAY TRIM(forx) COLOR RB/W ENDIF m=m+1 IF LINE>19 .AND. TYPE("TAGLIST[M,1]")#"L" @LINE+1,4 SAY "Press any key to see more index tags" COLOR R/W STORE INKEY(0) TO it @ 1,2 FILL TO 22,77 COLOR W/W LINE=2 ELSE LINE=LINE+1 ENDIF ENDDO @LINE+1,4 SAY "Finished viewing file....Press any key to continue" COLOR R/W endif STORE INKEY(0) TO it CLEAR EMPTY=LTRIM(STR(DISKSPACE()/RECSIZE(),10)) @11,11 FILL TO 15,71 COLOR /N @10,10 FILL TO 14,70 COLOR /W @ 12,15 SAY "You have room to add approximately: " COLOR N/W @ 12,51 SAY EMPTY COLOR R/W @ 12,51+LEN(EMPTY)+1 SAY " records" COLOR N/W STORE INKEY(1.2) TO it CLEAR @4,3 FILL TO 6,41 COLOR /N @3,2 FILL TO 5,40 COLOR /W @4,3 SAY "File: " COLOR R/W @4,9 SAY mdbf COLOR N/W DO shadowng WITH 9,24,17,59 ACTIVATE POPUP c_hoser IF LASTKEY()=27 EXIT ENDIF ENDDO CLEAR RELEASE taglist RELEASE condit RELEASE POPUP lookfile RELEASE POPUP c_hoser RELEASE WINDOW indexer RELEASE MDIR ERASE (mtemp) ERASE holdind.txt ON ERROR ON ESCAPE SET CURSOR ON CLOSE DATABASE RETURN *!********************************************************************* *! *! Procedure: M_CHOICE *! *! Called by: BUILDMDX.PRG *! *! Calls: PRINTDBF *! : R_INDEX *! : DELREIN *! Defines Case bar()'s from Popup *!********************************************************************* PROCEDURE m_choice PARAMETER mdbf,l_fldnum DO CASE CASE BAR()=3 @23,27 SAY "Please Wait while Printing" SET CONSOLE OFF DO printdbf WITH mdbf,l_fldnum,mlineno SET CONSOLE ON @23,27 SAY " Finished printing " STORE INKEY(.5) TO it @23,24 CLEAR TO 23,60 CASE BAR()=4 DO r_index WITH mdbf CASE BAR()=5 DO delrein WITH mdbf,N,mdir CASE BAR()=6 again=.T. DEACTIVATE POPUP CASE BAR()=7 IF mlineno>1 SET PRINTER ON EJECT PAGE SET PRINTER OFF ON ERROR ON ESCAPE ENDIF STORE .F. TO l_ookmore DEACTIVATE POPUP ENDCASE *!********************************************************************* *! *! Procedure: DELREIN *! *! Called by: M_CHOICE *! *! Calls: CHK_FILE *! : LOCK_REP *! : TAGBLD *! : CHECKFOR *! *! Uses: CONDIT.DBF WITH PATH *! : DEFINIT.DBF WITH PATH *! : MDBF THE CHOSEN DBF FILE WITH PATH *! The blood sweat and tears of this program saves index information *! If elected deletes the MDX tag then recreates the index *! *!********************************************************************* PROCEDURE delrein && DELETE MDX AND REINDEX PARAMETER mdbf,N,mdir d_index=.T. IF .NOT. FILE("DEFINIT.DBF") ACTIVATE WINDOW indexer @1,27 SAY "ERROR" COLOR R/W* @2,1 SAY " The file 'DEFINIT.DBF' does not exist" COLOR N/W @4,13 SAY ".......Press any key to exit......" COLOR W+/N STORE INKEY(0) TO it DEACTIVATE WINDOW indexer RETURN ENDIF IF CHK_FILE(MDBF,MDIR,GEN2)=.T. d_index=.T. ELSE d_index=.F. RETURN ENDIF PATH=AT("\",mdbf) m_path=STUFF(mdbf,PATH,1,"-") DO WHILE PATH#0 pathld=PATH-1 PATH=AT("\",m_path) m_path=STUFF(m_path,PATH,1,"-") ENDDO m_path= SUBSTR(mdbf,1,pathld) SET DIRECTORY TO &m_path && Change to path of dbase file to avoid DO WHILE d_index=.T. && Warning if Set Path (DOS) points to a SELECT C && directory containing the same DBF name m_cond=mdir+"\condit.dbf" && The wrong index may be created USE (m_cond) SET ORDER TO TAG tager SELECT B m_defin=mdir+"\definit.dbf" USE (m_defin) SET FILTER TO typer="D" SET ORDER TO TAG d_base GO TOP SEEK mdbf IF FOUND() d_recno=RECNO() SET FILTER TO typer="S" SEEK mdbf IF FOUND() m_ind=2 ind=2 ELSE SET FILTER TO GO d_recno m_match=.T. DO COMPTAG WITH m_match IF m_match=.F. SAVE SCREEN TO hold SECOND=.T. @6,11 FILL TO 21,71 COLOR /N @5,10 FILL TO 20,70 COLOR W/W @6,14 SAY "MDX EXPRESSION DEFAULT EXPRESSION" COLOR R/W LINE=7 m=1 H=STR(m,2) m_fld="EXPRESS"+H DO WHILE TYPE("TAGLIST[M,1]")#"L" @ LINE,12 SAY taglist[M,2] COLOR N/W H=STR(m,2) m_fld="EXPRESS"+LTRIM(H) IF .NOT. EMPTY(&m_fld) @ LINE,42 SAY TRIM(&m_fld) COLOR N/W ENDIF IF LINE>17 .AND. TYPE("TAGLIST[M,2]")#"L" @LINE+1,4 SAY "Press any key to see more index tags" COLOR R/W STORE INKEY(0) TO it @ 7,10 FILL TO 20,70 COLOR W/W LINE=7 ELSE LINE=LINE+1 m=m+1 ENDIF ENDDO DO WHILE .NOT. EMPTY(&m_fld) H=STR(m,2) m_fld="EXPRESS"+LTRIM(H) @ LINE,42 SAY TRIM(&m_fld) COLOR N/W IF LINE>17 .AND. LTRIM(&m_fld)#"" @LINE+1,4 SAY "Press any key to see more index tags" COLOR R/W STORE INKEY(0) TO it @ 7,10 FILL TO 20,70 COLOR W/W LINE=7 ELSE LINE=LINE+1 m=m+1 ENDIF ENDDO @23,12 SAY "Do you wish to save present MDX as a secondary file: " GET SECOND ; PICTURE "Y" MESSAGE "Press Y to Save N to not save" COLOR GR+/B,W+/R READ CLEAR IF SECOND=.T. ACTIVATE WINDOW indexer @2,1 SAY " Saving Index expression to DEFINIT.DBF as Secondary" COLOR N/W DO lock_rep WITH "S" @2,1 FILL TO 2,55 COLOR W/W DEACTIVATE WINDOW indexer m_ind=2 ind=2 CLEAR RESTORE SCREEN FROM hold RELEASE SCREEN hold ELSE m_ind=2 ind=1 R_BUILD="D" CLEAR DECLARE tagbld[47,3] DO tagbld RESTORE SCREEN FROM hold RELEASE SCREEN hold ENDIF ELSE m_ind=1 ind=1 ENDIF ENDIF ELSE ACTIVATE WINDOW indexer @2,1 SAY " Saving Index expression to DEFINIT.DBF as Default" COLOR N/W DO lock_rep WITH "D" d_recno=RECNO() m_ind=1 && EXPRESSES NUMBER OF MATCHED INDEXES STORED @2,1 FILL TO 2,55 COLOR W/W DEACTIVATE WINDOW indexer ENDIF IF m_ind=2 .AND. ind=2 SAVE SCREEN TO hold m_m=1 m_expres="EXPRESS" m_condit="CONDIT" m_name="NAME" B=LTRIM(STR(m_m,2)) expresr=m_expres+B conditr=m_condit+B namer=m_name+B m_ore=.T. DECLARE sectag[47,3] DO WHILE m_ore sectag[M_M,1]=&namer sectag[M_M,2]=&expresr sectag[M_M,3]=&conditr m_m=m_m+1 B=LTRIM(STR(m_m,2)) expresr=m_expres+B conditr=m_condit+B namer=m_name+B IF EMPTY(&expresr) m_ore=.F. ENDIF ENDDO m_m=m_m-1 CLEAR GO TOP SET FILTER TO m=1 n_n=1 g_more=.T. m_ore=.T. GO d_recno DO WHILE g_more @6,6 FILL TO 21,76 COLOR /N @5,5 FILL TO 20,75 COLOR W/W @6,9 SAY "SECONDARY EXPRESS FOR: DEFAULT EXPRESS FOR:" COLOR R/W LINE=7 g_more=.F. DO WHILE m=<m_m .AND. .NOT. g_more @ LINE,6 SAY LEFT(TRIM(sectag[M,2]),19) COLOR N/W IF sectag[M,3]=.T. SELECT C SEEK TRIM(MDBF)+TRIM(sectag[M,1])+"S" @ LINE,26 SAY LEFT(C->CONEXPRESS,15) COLOR RB/W SELECT B ENDIF m=m+1 IF LINE>17 IF m<=m_m g_more=.T. ENDIF LOOP ELSE LINE=LINE+1 ENDIF ENDDO LINE=7 B=LTRIM(STR(n_n,2)) expresr=m_expres+B conditr=m_condit+B namer=m_name+B DO WHILE m_ore @LINE,40 SAY LEFT(TRIM(&expresr),19) COLOR N/W IF &CONDITR=.T. T_HOLD=TRIM(&NAMER) SELECT C SEEK TRIM(MDBF)+T_HOLD+"D" @LINE,60 SAY LEFT(TRIM(C->CONEXPRESS),15) COLOR RB/W SELECT B ENDIF n_n=n_n+1 B=LTRIM(STR(n_n,2)) expresr=m_expres+B conditr=m_condit+B namer=m_name+B IF EMPTY(&expresr) m_ore=.F. LOOP ENDIF IF LINE>17 .AND. .NOT. EMPTY(&expresr) m_ore=.F. g_more=.T. @20,12 SAY "Press any key to see more index tags" COLOR R/W STORE INKEY(0) TO it LOOP ENDIF LINE=LINE+1 ENDDO @20,12 SAY "Finished...press any key" COLOR R/W STORE INKEY(0) TO it ENDDO r_build=SPACE(1) @23,9 SAY "Selecting R will replace a stored expression with the present MDX " @22,27 SAY "Select index to rebuild: " GET r_build PICTURE "@! X" VALID ; UPPER(r_build) $ "S,D,R,E" MESSAGE "Choose <S> for Secondary <D> for Default <R> to replace or <E> to Exit" ; ERROR "Enter S,D,R OR E Only" COLOR GR+/B,R/W READ IF UPPER(r_build)="E" CLEAR RESTORE SCREEN FROM hold RELEASE sectag RELEASE SCREEN hold d_index=.F. LOOP ENDIF IF UPPER(r_build)="R" @22,0 CLEAR TO 23,79 r_build=space(1) @22,23 SAY "Select Stored index to Replace: " GET r_build PICTURE "@! X" VALID ; UPPER(r_build) $ "S,D" MESSAGE "Choose <S> for Secondary or <D> for Default" ; ERROR "Enter S or D only" COLOR GR+/B,W+/R READ SET FILTER TO typer=UPPER(r_build) GO TOP SEEK trim(mdbf) IF FOUND() DELETE FOR TRIM(D_BASE)=MDBF SELECT C SET FILTER TO TYPER=UPPER(R_BUILD) DELETE FOR TRIM(D_BASE)=MDBF SET EXCLUSIVE ON SELECT B SET FILTER TO PACK SELECT C SET FILTER TO PACK SET EXCLUSIVE OFF SELECT B ENDIF restore screen from hold release screen hold ACTIVATE WINDOW indexer IF R_BUILD="S" M_BUILD="Secondary" ELSE M_BUILD="Default" ENDIF @2,1 SAY " Placing MDX tags in DEFINIT.DBF as "+M_BUILD COLOR N/W DO lock_rep WITH r_build @2,1 FILL TO 2,55 COLOR W/W DEACTIVATE WINDOW indexer LOOP ENDIF IF UPPER(r_build)="S" SET FILTER TO typer="S" SEEK mdbf ELSE SET FILTER TO typer="D" SEEK mdbf ENDIF DECLARE tagbld[47,3] DO tagbld CLEAR RESTORE SCREEN FROM hold RELEASE SCREEN hold ENDIF ACTIVATE WINDOW indexer @2,9 SAY "Proceed with Rebuild of Index now: " GET d_index PICTURE "Y" ; MESSAGE "Warning present MDX will be deleted and a new MDX file created" COLOR N/W,GR+/B READ IF d_index=.F. DEACTIVATE WINDOW indexer LOOP ENDIF IF .NOT. FLOCK() @1,27 SAY "ERROR" COLOR R/W* @2,1 SAY " File is in use by:"+LKSYS(2)+" please verify" COLOR N/W @4,13 SAY ".......Press any key to exit......" COLOR W+/N STORE INKEY(0) TO it DEACTIVATE WINDOW indexer d_index=.F. LOOP ENDIF @2,9 FILL TO 2,45 COLOR W/W SELECT B USE IN A STORE AT(".",mdbf) TO hhh hhh=hhh-1 STORE SUBSTR(mdbf,1,hhh) TO mmdx && stores name of MDX file mmdx=mmdx+".MDX" ERASE &mmdx SET INSTRUCT OFF SELECT B IF RLOCK() ELSE ACTIVATE WINDOW indexer @1,27 SAY "ERROR" COLOR R/W* @2,1 SAY " The file cannot be used exclusively" COLOR N/W @4,13 SAY ".......Press any key to exit......" COLOR W+/N STORE INKEY(0) TO it DEACTIVATE WINDOW indexer RETURN ENDIF SET EXCLUSIVE ON SELECT A USE (mdbf) SET INSTRUCT ON ACTIVATE WINDOW indexer n_n=1 IF m_ind=2 SET CURSOR OFF SET TALK ON SELECT C DO WHILE TYPE("TAGBLD[N_N,1]")#"L" IF tagbld[N_N,3]=.F. SELECT A @ 1,3 SAY "INDEXING ON "+TAGBLD[N_N,1] COLOR B/W @ 1,1 SAY "▀" COLOR R/W* store inkey(.5) to it INDEX ON &tagbld[N_N,2] TAG &tagbld[N_N,1] @ 1,0 FILL TO 4,58 COLOR W/W ELSE SELECT C SEEK TRIM(mdbf)+TRIM(tagbld[N_N,1])+r_build STORE conexpress TO ex_p SELECT A @ 1,3 SAY "INDEXING ON "+ TAGBLD[N_N,1]+ " FOR "+ex_p COLOR B/W @ 1,1 SAY "▀" COLOR R/W* store inkey(.5) to it INDEX ON &tagbld[N_N,2] TAG &tagbld[N_N,1] FOR &ex_p @ 1,0 fill to 4,58 COLOR W/W ENDIF n_n=n_n+1 ENDDO SET TALK OFF SELECT A RELEASE tagbld ELSE SET CURSOR OFF SET TALK ON DO WHILE TYPE("TAGLIST[N_N,1]")#"L" forx=SPACE(30) IF condition=.T. DO checkfor WITH n_n,forx ENDIF IF .NOT. EMPTY(forx) @ 1,3 SAY "INDEXING ON "+ TAGLIST[N_N,1]+ " FOR "+forx COLOR B/W @ 1,1 SAY "▀" COLOR R/W* STORE INKEY(.5) TO IT INDEX ON &taglist[N_N,2] TAG &taglist[N_N,1] FOR &forx @1,0 FILL TO 4,58 COLOR W/W ELSE @ 1,3 SAY "INDEXING ON "+TAGLIST[N_N,1] COLOR B/W @ 1,1 SAY "▀" COLOR R/W* STORE INKEY(.5) TO IT INDEX ON &taglist[N_N,2] TAG &taglist[N_N,1] @1,0 FILL TO 4,58 COLOR W/W ENDIF n_n=n_n+1 ENDDO SET TALK OFF SET EXCLUSIVE OFF ENDIF DEACTIVATE WINDOW indexer d_index=.F. ENDDO SET DIRECTORY TO &mdir CLOSE DATABASE SET EXCLUSIVE OFF SELECT A use(mdbf) RETURN *!********************************************************************* *! *! Procedure: LOCK_REP *! *! Called by: DELREIN (procedure in BUILDMDX.PRG) *! *! Calls: CHECKFOR (procedure in BUILDMDX.PRG) *! Replace the stored Index Tags for mdbf in definit.dbf and condit.dbf *!********************************************************************* PROCEDURE lock_rep PARAMETER fl_t APPEND BLANK m_name="NAME" m_expres="EXPRESS" m_condit="CONDIT" m=1 DO WHILE TYPE("TAGLIST[M,1]")#"L" forx=SPACE(30) IF condition=.T. DO checkfor WITH m,forx ENDIF B=LTRIM(STR(m,2)) m_namer=m_name+B m_expresr=m_expres+B m_conditr=m_condit+B REPLACE &m_namer WITH taglist[M,1] REPLACE &m_expresr WITH taglist[M,2] IF .NOT. EMPTY(forx) REPLACE &m_conditr WITH .T. SELECT C APPEND BLANK REPLACE d_base WITH mdbf REPLACE conexpress WITH forx REPLACE tagname WITH taglist[M,1] REPLACE typer WITH fl_t SELECT B ELSE REPLACE &m_conditr WITH .F. ENDIF m=m+1 ENDDO REPLACE d_base WITH mdbf REPLACE typer WITH fl_t RETURN *!********************************************************************* *! *! Procedure: R_INDEX *! *! Called by: M_CHOICE (procedure in BUILDMDX.PRG) *! *! Calls: CHK_FILE (procedure in BUILDMDX.PRG) *! *! Uses: MDBF *! Reindex the DBF *!********************************************************************* PROCEDURE r_index PARAMETER mdbf d_index=.T. IF CHK_FILE(MDBF,MDIR,GEN2)=.T. d_index=.T. ELSE d_index=.F. RETURN ENDIF CLOSE DATABASE SET EXCLUSIVE ON SELECT A USE (mdbf) ACTIVATE WINDOW indexer SET TALK ON REINDEX SET TALK OFF DEACTIVATE WINDOW indexer SET EXCLUSIVE OFF CLOSE DATABASE SELECT A use(mdbf) RETURN *!********************************************************************* *! *! Function: CHK_FILE *! *! Called by: DELREIN (procedure in BUILDMDX.PRG) *! : R_INDEX (procedure in BUILDMDX.PRG) *! Checks size requirements for Reindexing or creating Index *!********************************************************************* FUNCTION chk_file PARAMETER mdbf,mdir,gen2 xtemp=tempfile(GEN2) COPY FILE indtemp.dbf TO &xtemp SET DEFAULT TO &gen2 STORE DISKSPACE() TO dskspace SET DEFAULT TO &mdir SET CONSOLE OFF SET PRINTER TO SET PRINTER TO FILE "holdind.txt" SET PRINTER ON DIR &MDBF SET PRINTER OFF SET PRINTER TO SET CONSOLE ON SELECT B use (xtemp) APPEND FROM holdind.txt TYPE DELIMITED go top do while .not. eof() IF at("file",hold)>0 store trim(hold) to m_fsize ENDIF SKIP enddo STORE AT("byte",m_fsize) to fsr fsr=fsr-2 STORE TRIM(SUBSTR(m_fsize,1,fsr)) TO m_fsize s_hld=VAL(m_fsize) IF dskspace/s_hld <2 ACTIVATE WINDOW indexer @1,27 SAY "ERROR" COLOR R/W* @ 2,1 SAY "The Temporary directory is too small to reindex this file" COLOR N/W @4,13 SAY ".......Press any key to exit......" COLOR W+/N STORE INKEY(0) TO it DEACTIVATE WINDOW indexer STORE .F. TO OKIND ELSE STORE .T. TO OKIND ENDIF SELECT A USE IN B ERASE HOLDIND.TXT ERASE (XTEMP) RETURN OKIND *-EOP:CHECK *!********************************************************************* *! *! Procedure: PRINTDBF *! *! Called by: M_CHOICE (procedure in BUILDMDX.PRG) *! *! Calls: MYDATE() (function in BUILDMDX.PRG) *! : PHEADER (procedure in BUILDMDX.PRG) *! : ENDPAGE (procedure in BUILDMDX.PRG) *! : CHECKFOR (procedure in BUILDMDX.PRG) *! Main program to print DBF structure and Index tags *!********************************************************************* PROCEDURE printdbf PARAMETER mdbf,l_fldnum,mlineno fieldnum=1 _PLENGTH=66 _PPITCH="elite" _PQUALITY=.T. _PEJECT="NONE" _PADVANCE ="LINEFEEDS" IF mlineno>1 _PLINENO=mlineno ENDIF STORE mydate(DATE()) TO m_td SET PRINTER ON PRINTJOB DO CASE CASE mlineno=1 DO pheader WITH mpage,m_td CASE _PLINENO>57 mpage=mpage+1 EJECT PAGE mlineno=1 DO pheader WITH mpage,m_td OTHERWISE ? ? ENDCASE ? IF _PQUALITY=.T. ?? ELSE ??"DATABASE: "+TRIM(mdbf) STYLE "BI" AT 23 ENDIF ? ?? TRIM(DBF())+" Contains The Following Fields:" AT 4 ? ?? "Name" STYLE "BU" AT 10 ?? "Type" STYLE "BU" AT 39 ?? "Length" STYLE "BU" AT 63 DO WHILE fieldnum<=l_fldnum x_tt=FIELD(fieldnum) ? ?? "FIELD # "+STR(fieldnum,2) + " "+FIELD(fieldnum) AT 6 DO CASE CASE TYPE(FIELD(fieldnum))="C" fieldtype="CHARACTER" x_te=LEN(&x_tt) x_tx=STR(x_te,3) CASE TYPE(FIELD(fieldnum))="N" .OR. TYPE(FIELD(fieldnum))="F" fieldtype="NUMERIC" x_tf=TRANSFORM(&x_tt,"@9") x_tg=LEN(x_tf) x_tp=AT(".",x_tf) x_ty=x_tg-x_tp x_tx=STR(x_tg,3) IF x_tp>0 x_tx=x_tx +" Decimal " +LTRIM(STR(x_ty)) ENDIF CASE TYPE(FIELD(fieldnum))="D" fieldtype="DATE" x_tx=" 8" CASE TYPE(FIELD(fieldnum))="L" fieldtype="LOGICAL" x_tx=" 1" CASE TYPE(FIELD(fieldnum))="M" fieldtype="MEMO" x_tx="64K" ENDCASE ?? fieldtype AT 35 ?? TRIM(x_tx) AT 64 fieldnum=fieldnum+1 IF _PLINENO>57 .AND. l_fldnum/fieldnum>1 DO endpage WITH mpage,m_td ? ?? "DATABASE: "+TRIM(mdbf) STYLE "BI" AT 36 ? ?? "Name" STYLE "BU" AT 10 ?? "Type" STYLE "BU" AT 39 ?? "Length" STYLE "BU" AT 63 ENDIF RELEASE ALL LIKE x_t* ENDDO ? ? IF _PLINENO>54 DO endpage WITH mpage,m_td ENDIF ? IF TYPE("taglist[1,1]")="L" ?? "No tags noted on: "+dbf() AT 30 ? ELSE ?? "The following index tags are noted on:"+mdbf ? ? ??" Tag Name Expression For " STYLE "B" AT 3 ? m=1 DO WHILE TYPE("TAGLIST[M,1]")#"L" forx=SPACE(30) IF condition=.T. DO checkfor WITH m,forx ENDIF ? ?? taglist[M,1] AT 5 ?? taglist[M,2] AT 30 IF condition=.T. ?? TRIM(forx) AT 66 ENDIF m=m+1 IF LINE>57 .AND. TYPE("TAGLIST[M,1]")#"L" DO endpage WITH mpage,m_td ENDIF ENDDO ENDIF mlineno=_PLINENO ENDPRINTJOB SET PRINTER OFF RETURN *!********************************************************************* *! *! Procedure: PHEADER *! *! Called by: PRINTDBF (procedure in BUILDMDX.PRG) *! : ENDPAGE (procedure in BUILDMDX.PRG) *! Called to begin a new page *!********************************************************************* PROCEDURE pheader PARAMETER mpage,m_td ? ? ?? m_td AT 5 ?? "Page: " AT 72 ?? mpage AT 78 FUNCTION "T" ? RETURN *!********************************************************************* *! *! Procedure: ENDPAGE *! *! Called by: PRINTDBF (procedure in BUILDMDX.PRG) *! *! Calls: PHEADER (procedure in BUILDMDX.PRG) *! Called to end a page *!********************************************************************* PROCEDURE endpage PARAMETER mpage,m_td EJECT PAGE mlineno=1 mpage=mpage+1 DO pheader WITH mpage,m_td RETURN *!********************************************************************* *! *! Procedure: TAGBLD *! *! Called by: DELREIN (procedure in BUILDMDX.PRG) *! Builds the Tag building array from information in Definit.dbf,Condit.dbf *!********************************************************************* PROCEDURE tagbld n_n=1 m_ore=.T. m_expres="EXPRESS" m_name="NAME" m_condit="CONDIT" DO WHILE m_ore B=LTRIM(STR(n_n,2)) expresr=m_expres+B namer=m_name+B conditr=m_condit+B IF EMPTY(&namer) m_ore=.F. ELSE tagbld[N_N,1]=&namer tagbld[N_N,2]=&expresr tagbld[N_N,3]=&conditr n_n=n_n+1 ENDIF ENDDO RETURN *!********************************************************************* *! *! Procedure: CHECKFOR *! *! Called by: BUILDMDX.PRG *! : DELREIN (procedure in BUILDMDX.PRG) *! : LOCK_REP (procedure in BUILDMDX.PRG) *! : PRINTDBF (procedure in BUILDMDX.PRG) *! Checks for existence of Conditional Tag in array Condit *!********************************************************************* PROCEDURE checkfor PARAMETER m,forx L=1 ENOUGH=.F. DO WHILE TYPE("CONDIT[L,1]")#"L" .AND. ENOUGH=.F. IF taglist[M,1]=condit[L,1] forx=condit[L,2] ENOUGH=.T. LOOP ELSE l=l+1 ENDIF ENDDO RETURN *!********************************************************************* *! *! Function: TEMPFILE() *! *! Called by: BUILDMDX.PRG *! Generate a temporary file name in Temp directory from indtemp.dbf *!********************************************************************* FUNCTION tempfile PARAMETER GEN2 IF RIGHT(GEN2,1)="\" tempf= (gen2+LTRIM(STR(RAND(-1)*100000000,8))+".DBF") ELSE tempf=(gen2+"\"+LTRIM(STR(RAND(-1)*100000000,8))+".DBF") ENDIF RETURN tempf *!********************************************************************* *! *! Procedure: ERR_OUT *! *! Called by: ON ERROR *! : ON ESCAPE *! ERROR EXIT PROGRAM *!********************************************************************* PROCEDURE ERR_OUT PARAMETER MDIR,M_ER,M_line m_err=.t. STORE MESSAGE() TO M_ESS IF AT("does not support quality",M_ESS)>0 _PQUALITY=.F. RETURN ENDIF SET DIRECTORY TO &MDIR STORE WINDOW() TO WIN STORE POPUP() TO POP STORE MESSAGE() TO M_MESS IF .NOT. EMPTY(WIN) DEACTIVATE WINDOW &WIN ENDIF SET BELL TO 400,2 ?? CHR(7) SET BELL TO 400,2 ?? CHR(7) SET BELL TO 400,2 ?? CHR(7) SET BELL TO 200,7 ?? CHR(7) SET BELL TO ACTIVATE WINDOW INDEXER if m_er=125 .OR. m_er=126 @ 2,1 SAY "WARNING " color r/w @ 2,10 SAY "Printer must be turned on and connected" color N/W @ 4,1 say " PRESS <ESC> to exit or any other key to continue " color n/w STORE INKEY(0) TO IT IF IT#27 DEACTIVATE WINDOW INDEXER RETURN ENDIF ELSE IF M_ER>0 @ 2,1 SAY "ERROR: " COLOR R/W @ 2,9 SAY M_MESS COLOR N/W @ 3,10 say "line # " @ 3,18 say m_line @ 4,1 say "Press any key to exit" COLOR N/W store inkey(0) to IT ENDIF DEACTIVATE WINDOW INDEXER ENDIF CLOSE DATABASE ERASE holdind.txt ERASE (mtemp) ERASE (XTEMP) IF SET("PRINTER")="ON" SET PRINTER OFF ENDIF SET CONSOLE ON IF .NOT. EMPTY(POP) L_OOKMORE=.F. DEACTIVATE POPUP ENDIF MDIR="DONE" RETURN *-EOP: ERR_OUT *!********************************************************************* *! *! Function: CHECKDBF *! *! Check user has not selected DEFINIT.DBF or CONDIT.DBF *!********************************************************************* FUNCTION CHECKDBF PARAMETER MDBF,MDIR IF MDIR+"\DEFINIT.DBF"=MDBF .OR. MDIR+"\CONDIT.DBF"=MDBF .OR. MDIR+"\INDTEMP.DBF"=MDBF FILE=.T. ELSE FILE=.F. ENDIF RETURN FILE *EOP: CHECKDBF() *: EOF: BUILDMDX.PRG *!********************************************************************* *! *! Procedure: COMPTAG *! *! Compares Tags to see if expressions are the same *!********************************************************************* PROCEDURE COMPTAG PARAMETER m_match m_m=1 m_expres="EXPRESS" m_finis=.F. DO WHILE m_finis=.F. && Check to see if present MDX TAGS B=LTRIM(STR(m_m)) && are the same as the Default stored expresr=m_expres+B DO CASE CASE TYPE("TAGLIST[M_M,2]")="L" .AND. EMPTY(&expresr) m_finis=.T. CASE TYPE("TAGLIST[M_M,2]")="L" .AND. .NOT. EMPTY(&expresr) m_match=.F. m_finis=.T. CASE TYPE("TAGLIST[M_M,2]")#"L" .AND. EMPTY(&expresr) m_match=.F. m_finis=.T. CASE TRIM(taglist[M_M,2])=TRIM(&expresr) m_match=.T. CASE TRIM(taglist[M_M,2])#TRIM(&expresr) m_match=.F. m_finis=.T. ENDCASE m_m=m_m+1 ENDDO RETURN *!********************************************************************* *! *! Procedure: SHADOWNG *! *! Called by: BUILDMDX.PRG *! The famous Dbase shadowing routine *!********************************************************************* PROCEDURE shadowng && displays shadow that grows PARAMETER x1,y1,x2,y2 PRIVATE x1,y1,x2,y2 @ x1+1,y1+2 FILL TO x2+1,y2+2 COLOR N+/N RETURN *-- EOP: Shadowng *!********************************************************************* *! *! Function: EMPTY() *! Looks to see if memory variable or field is empty *!********************************************************************* FUNCTION EMPTY PARAMETER X PRIVATE retval, lc_type lc_type = TYPE("x") DO CASE CASE lc_type = "C" retval = (LEN(TRIM(X))=0) CASE lc_type$"NF" retval = (X=0) CASE lc_type = "D" retval = (" "$DTOC(X)) OTHERWISE &&lc_type = "U" retval = .T. ENDCASE RETURN (retval) *-- EOP: Empty() *!********************************************************************* *! *! Function: MYDATE() *! converts DATE() to Month,Day,Year format *!********************************************************************* FUNCTION MYDATE *Author: Gerald J. Fay M.D. PARAMETER MDATE1 STORE CDOW(MDATE1)+", "+CMONTH(MDATE1)+" "+LTRIM(STR(DAY(MDATE1),2))+", "+STR(YEAR(MDATE1),4) TO RETDATE RETURN RETDATE *--EOP:Mydate() *!********************************************************************* *! *! Function: CENTER *! *! Centers SAY or GET expressions *!********************************************************************* FUNCTION Center * UDF to center a string. * lc_string = String to center * ln_width = Width of screen to center in PARAMETER lc_string, ln_width RETURN ((ln_width/2)-(LEN(lc_string)/2)) *EOP: Center() *: EOF: BUILDMDX.PRG