Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : XCOUNT.ZIP
Filename : XCOUNT.PRG

* PROGRAM: XCOUNT.PRG
* AUTHOR: Dr. T. D. Coyle, GPR Systems
* 11400 Game Preserve Road, Gaithersburg, MD 20878
* [301-948-9510]
* WRITTEN: 03-13-89
* PURPOSE: Count and cross tabulate DBF's
*
* REVISIONS:
*
* LAST REVISION Wed 12-06-1989 19:53:44
* DATABASES:
* NOTES: Based on XTAB.PRG
* by Miguel Campos and Mane Gomez
* from PC Magazine, 12/23/86, p. 306
CLEAR ALL
SET TALK OFF
PROCFILE="XCOUNT" && put in name of final version
SET PROCEDURE TO XCOUNT
SET SAFETY OFF
SET STATUS OFF
SET SCOREBOARD OFF
PUBLIC MFIL,ABORT,COUNTEXP,KEYEXP,SROW,FLEN,WORDEXP,TOCOUNT
PUBLIC MTXT,MTYPE,MTNAME,MTNAMEX,SUMNAME
STORE .F. TO ABORT
DO SCRN1
DO GETFILE
IF ABORT
RETURN
ENDIF
SET STATUS ON
DO DISPFLDS
DO GETFLDS
DO PROCESS
DO OPSTYLE
DO OUTPUT
DO CLOSEDEV
WAIT
CLOSE DATA
DELETE FILE &SUMNAME
DELETE FILE TEMPFIL.DBF
DELETE FILE TEMP.NDX
CLEAR
SET SCOREBOARD ON
SET STATUS ON
LASTXT="XCOUNT RUN COMPLETED AT "+TIME()+" ON "+DTOC(DATE())
@ 10, 5 SAY LASTXT
IF MTXT$'13'
@ 12, 5 SAY "RESULTS ARE STORED IN TEXT FILE &MTNAMEX"
ENDIF
CLEAR ALL
CLOSE PROCEDURE
SET SAFETY ON
SET TALK ON
RETURN

*|PR SCRN1
PROCEDURE SCRN1
*displays opening screen
VAR1="XXXXX"
VAR2="COUNT"
VERVAR="Version 1.1, 12-06-1989"
L=0
C=2
DO WHILE L<25
@ L, C SAY VAR1
L=1+L
C=1+C
ENDDO
C=C-1
L=0
DO WHILE L<25
@ L, C SAY VAR2
L=L+1
C=C-1
ENDDO
*@ 12, 14 say "


"
@ 6, 35 SAY "þ X C O U N T"
@ 8,37 SAY "DATABASE ANALYSIS PROGRAM"
@ 9, 37 SAY VERVAR
RETURN

*|PR GETFILE
PROCEDURE GETFILE
*gets name of file to be searched from the keyboard
* LAST REVISION Sat 01-07-1989 20:10:17
MFIL=SPACE(50)
FILEOK=.N.
DO WHILE .NOT. FILEOK
@ 11,25 SAY "Enter name of file to process or hit ENTER to abort"
@ 12,25 SAY "(Include path if not on default directory):"
@ 14, 25 GET MFIL
READ
IF LEN(TRIM(MFIL))=0
ABORT=.T.
EXIT
ENDIF
MFIL=UPPER(TRIM(MFIL))
IF SUBSTR(MFIL,LEN(MFIL)-3,4)=".DBF"
MFIL=SUBSTR(MFIL,1,LEN(MFIL)-4)
ENDIF
MFILEXT=MFIL+".DBF"
MFILDBT=MFIL+".DBT"
FILDELIM="'"+MFILEXT+"'"
IF .NOT. FILE(&FILDELIM)
@ 15, 28 SAY "FILE &MFILEXT DOES NOT EXIST! TRY AGAIN"
MFIL=SPACE(50)
ELSE
FILEOK=.T.
ENDIF
NFIL=MFIL
NFILEXT=MFILEXT
NFILDBT=MFILDBT
ENDDO
CLEAR
RETURN


*|PR DISPFLDS
PROCEDURE DISPFLDS
*displays fields in selected file
* LAST REVISION Sat 01-07-1989 20:10:17
CLEAR
SELE A
USE &MFIL ALIAS ORIGFILE
COPY STRU EXTE TO TEMPFIL
SELE B
USE TEMPFIL
NUMFLDS=RECCOUNT()
BLOCK=SPACE(12)
SROW=1
SCOL=3
FLDCNTR=1
CLEAR
@ SROW, 3 SAY "THE FIELDS IN &MFIL ARE:"
SROW=3
DO WHILE .NOT. EOF()
DO WHILE SCOL<=65 .AND. .NOT. EOF()
@ SROW,SCOL GET BLOCK
@ SROW,SCOL+1 GET FIELD_NAME
SCOL=SCOL+15
SKIP
FLDCNTR=FLDCNTR+1
ENDDO
SCOL=3
IF NUMFLDS>30
SROW=SROW+1
ELSE
SROW=SROW+2
ENDIF
ENDDO
CLEAR GETS
SROW=ROW()
RETURN

*|PR GETFLDS
PROCEDURE GETFLDS
*get keyboard input of fields to be counted
@ SROW+2, 5 SAY "Enter Field(s) for Count [RETURN when done] "
STORE "" TO COUNTEXP,KEYEXP,WORDEXP
GETFLDS=.T.
FLEN=0
I=1
DO WHILE GETFLDS .AND. LEN(KEYEXP)<250
SFLD=SPAC(25)
@ SROW+2+I, 5 SAY STR(I,2)+". " GET SFLD
READ
SFLD=UPPER(TRIM(SFLD))
IF LEN(SFLD)=0
KEYEXP=SUBSTR(KEYEXP,1,LEN(KEYEXP)-1)
EXIT
ENDIF
SELE B
SET EXACT ON
LOCATE FOR FIELD_NAME=SFLD
SET EXACT OFF
IF .NOT. FOUND()
@ SROW+3+I, 5 SAY "FIELD &SFLD DOES NOT EXIST, TRY AGAIN!"
SFLD=SPACE(25)
LOOP
ENDIF
SFLEN=FIELD_LEN
XFLEN=STR(FIELD_LEN,2)
XFDEC=STR(FIELD_DEC,1)
@ SROW+3+I, 5
SELE A
IF TYPE([&SFLD])='N'
KEYEXP=KEYEXP+'STR('+SFLD+',&XFLEN,&XFDEC)'
WORDEXP=WORDEXP+'STR('+SFLD+',&XFLEN,&XFDEC)'
FLEN=FLEN+SFLEN+1
COUNTEXP=COUNTEXP+SFLD
ENDIF
IF TYPE('&SFLD')='D'
KEYEXP=KEYEXP+'SUBSTR(DTOC(&SFLD),7,2)+"."+SUBSTR(DTOC(&SFLD),1,2)+'+;
'"."+SUBSTR(DTOC(&SFLD),4,2)'
WORDEXP=WORDEXP+'DTOC(&SFLD)'
COUNTEXP=COUNTEXP+SFLD
FLEN=FLEN+9
ENDIF
IF TYPE('&SFLD')='C'
FLEN=FLEN+SFLEN+1
keyexp=keyexp+SFLD
WORDEXP=WORDEXP+SFLD
COUNTEXP=COUNTEXP+SFLD
ENDIF
IF TYPE('&SFLD')="M" .OR. TYPE ('&SFLD')="L"
@ SROW+3+I, 5 SAY "SORRY, CAN'T COUNT LOGICAL OR MEMO FIELDS"
LOOP
ENDIF
COUNTEXP=COUNTEXP+","
KEYEXP=KEYEXP+"+' '+"
WORDEXP=WORDEXP+" "
I=I+1
ENDDO
RETURN

*|PR PROCESS
PROCEDURE PROCESS
*do counts and store them
CLEAR
? "PROCESSING FILE &MFILEXT"
? "COUNTING FIELDS &COUNTEXP"
SELE B
*convert this structure file to a new one
DELETE FOR RECNO()>2
PACK
GOTO 1
REPL FIELD_NAME WITH "TOT",FIELD_TYPE WITH "N",FIELD_LEN WITH 5,;
FIELD_DEC WITH 0
GOTO 2
REPL FIELD_NAME WITH "KEY",FIELD_TYPE WITH "C";
FIELD_LEN WITH FLEN,FIELD_DEC WITH 0
SUMNAME=TRIM(MFIL)+".DBX"
CREATE &SUMNAME FROM TEMPFIL && file to hold the counts
USE &SUMNAME
SELE A
INDEX ON &KEYEXP TO TEMP
SET INDEX TO TEMP
SET SAFE ON
KEYREF=&KEYEXP
*WORDREF=&WORDEXP
TOCOUNT=0
DO WHILE .NOT. EOF()
COUNT WHILE &KEYEXP=KEYREF TO NCOUNT
TOCOUNT=TOCOUNT+NCOUNT
SELE 2
APPEND BLANK
REPL TOT WITH NCOUNT,KEY WITH KEYREF
SKIP
SELE 1
KEYREF=&KEYEXP
ENDDO
RETURN



*|PR OPSTYLE
PROCEDURE OPSTYLE
*select output style (save/print/display)
* LAST REVISION Sat 01-07-1989 20:10:17
CLEAR
STORE ' ' TO MTXT
DO WHILE MTXT<"1" .OR. MTXT>"4"
@ 2, 14 SAY "XCOUNT DATA ANALYSIS COMPLETE, READY TO PRODUCE TABLE"
@ 5,20 SAY 'DO YOU WANT TO . . . '
@ 8,20 SAY '1- SAVE THE TABLE TO A TEXT FILE.'
@ 10,20 SAY '2- PRINT THE TABLE.'
@ 12,20 SAY '3- SAVE AS TEXT FILE AND PRINT TABLE.'
@ 14,20 SAY '4- DISPLAY TABLE ONLY.'
@ 17,20 SAY 'SELECT 1, 2, 3 OR 4: ' GET MTXT
READ
CLEAR
IF MTXT="1" .OR. MTXT="3"
FILOK=.N.
DO WHILE .NOT. FILOK
MTNAME=SPACE(40)
@ 6, 5 SAY "ENTER A FILE NAME FOR THE TEXT FILE "
@ 7, 5 SAY "(Specify Path to Write on Another Directory)"
@ 9, 5 SAY "ÍÍ>" GET MTNAME
READ
MTNAME=TRIM(MTNAME)
IF SUBSTR(MTNAME,LEN(MTNAME)-3,1)<>"."
MTNAMEX=MTNAME+".TXT"
ELSE
MTNAMEX=MTNAME
ENDIF
IF FILE('&MTNAMEX')
OVRWRITE=.Y.
@ 11, 5 SAY "FILE &MTNAME ALREADY EXISTS"
@ 12, 5 SAY "DO YOU WANT TO OVERWRITE? " GET OVRWRITE ;
PICTURE "Y"
READ
IF .NOT. OVRWRITE
@ 11,5 CLEAR TO 12,79
LOOP
ENDIF
ENDIF
FILOK=.Y.
ENDDO
SET ALTERNATE TO &MTNAMEX
SET ALTERNATE ON
ENDIF
IF MTXT="2" .OR. MTXT="3"
CLEAR
STORE ' ' TO MTYPE
@ 6, 5 SAY 'DO YOU WANT CONDENSED OR NORMAL TYPE?'
@ 7, 5 SAY 'ENTER C FOR CONDENSED OR ANY OTHER KEY FOR NORMAL: ' GET MTYPE
READ
@ 9,5 SAY 'TURN YOUR PRINTER ON AND PRESS ANY KEY TO CONTINUE'
?
WAIT ""
SET PRINT ON
IF MTYPE = 'C'
? CHR(15)
ENDIF
EJECT
ENDIF
ENDDO
RETURN

*|PR OUTPUT
PROCEDURE OUTPUT
*display or print results
CLEAR
SELE 2
? "XCOUNT ANALYSIS OF &MFIL"
? "Produced "+DTOC(DATE())+" at "+TIME()
? "Fields: &COUNTEXP"
?
SET HEADING OFF
DISP OFF ALL KEY,TOT
? "TOTAL",TOCOUNT
SET HEADING ON
DO CLOSEDEV
RETURN


*|PR CLOSEDEV
PROCEDURE CLOSEDEV
* restore printer and close alternate if necessary
* LAST REVISION Sun 01-15-1989 13:40:42
IF MTXT = '1' .OR. MTXT = '3'
CLOSE ALTERNATE
ENDIF
IF MTXT = '2' .OR. MTXT = '3'
? CHR(18)
SET PRINT OFF
ENDIF
RETURN