home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
pack_s87.zip
/
SAFEPACK.PRG
next >
Wrap
Text File
|
1988-04-02
|
2KB
|
97 lines
* Routine to safely remove deleted records from DBFs under clipper
* Procedure Safepack
*
* By: Walt Morgan
* Morgan & Associates
* PO Box 353
* Lawrenceburg, TN 38464
* (615) 762-3300
*
*-- Sample uses of FOPEN, FREAD, and FCLOSE Functions in Clipper '87
*
PARAMETERS MFILE
IF PCOUNT() != 1
@ 0,0 CLEAR
ACCEPT "Enter Name of DBF to be Packed: " to mfile
ELSE
@ 0,0 CLEAR
ENDIF
MFILE = UPPER(LTRIM(TRIM(MFILE)))
IF LEN(TRIM(MFILE)) = 0
RETURN
ENDIF
IF AT(".",MFILE) > 0
MFILE = SUBSTR(MFILE,1,AT(".",MFILE) - 1)
ENDIF
MMEMO = MFILE + ".DBT"
MFILE = MFILE + ".DBF"
? MFILE
*-- TEST FOR ASSOCIATED .DBT FILE (MEMO FIELDS IN DBF)
HANDLE = FOPEN("&MFILE",0) && OPEN .DBF FILE FOR READ-ONLY
IF FERROR() != 0
? 'Cannot open file, DOS Error: '+ LTRIM(TRIM(STR(FERROR())))
INKEY(0)
RETURN
ELSE
? 'File open...'
ENDIF
*-- Determine if file has an associated .DBT file (Memo fields in DBF)
*-- Read in first byte of DBF Header
BLOCK = 1
BUFFER = SPACE(2)
BYTES = FREAD(HANDLE,@BUFFER,BLOCK)
IF BUFFER = CHR(131) && â = 83h = Associated .DBT File = 03h = None
?? ' Has an associated .DBT file'
ELSE
?? ' Has no associated .DBT file'
ENDIF
FCLOSE(HANDLE)
?? ' ...File closed'
IF .NOT. FILE("&MFILE")
? MFILE + ' File Not Found...Press Any Key to Continue'
INKEY(0)
RETURN
ENDIF
IF BUFFER = CHR(131) .AND. .NOT. FILE("&MMEMO")
? MMEMO + ' File Not Found...Press Any Key to Continue'
INKEY(0)
RETURN
ENDIF
mrow=row()
mcol=col()
MSELECT = SELECT()
SELECT 0
@ mrow,mcol say ''
USE &MFILE
ORIGRECS = RECCOUNT()
COUNT FOR DELETED() TO DELERECS
SET DELETED ON
COPY TO _TEMP.TMP
USE _TEMP.TMP
NEWRECS = RECCOUNT()
USE
IF (NEWRECS + DELERECS) = ORIGRECS
!DEL &MFILE
!REN _TEMP.TMP &MFILE
IF FILE ("_TEMP.DBT")
! DEL &MMEMO
! REN _TEMP.DBT &MMEMO
ENDIF
packmsg = 'File has been sucessfully packed'
ELSE
packmsg = "File Could Not Be Packed...Press Any Key to Continue"
INKEY(0)
ENDIF
@ 5,0 say packmsg
SELECT(MSELECT)
RETURN