Power-Programmierung/CD1.mdf/basic/library/vb/db4pack/packtabl.bas

BASIC Source File | 1994-02-10 | 10.1 KB | 346 lines

'Sub PackTable Packs dBASE IV tables.
'Use Freely in your applications but use at your own risk.
'Comments are welcome to Darryl Buchanan (CompuServe 71435,1442)
'
'Visual Basic 3.0 does not provide a Pack function for dBASE IV
'tables!  I wrote this function for my own applications to
'provide such a capability.  It works with dBASE IV (.DBF) files
'with maintained indexes (.MDX) and with attached memo (.DBT)
'files.
'
'This subroutine works in the following fashion:
'1. Delete any pre-existing temp files:
'   (XXXXXXXX.DBF, XXXXXXXX.DBT, or XXXXXXXX.MDX)
'2. Read the old tables field and index descriptions.
'3. Rename the existing files to XXXXXXXX.*
'   (NOTE:  dBASE IV tables with .MDX indexes maintain
'   the original table name in the index header.  That's
'   why we first rename the old file to xxxxxxxx.* and
'   create the new file with the original name.  Visual
'   Basics database engine can read the file ok with the
'   new xxxxxxxx name, but Paradox for Windows chokes and
'   says the index is corrupt.  Go figure.  Anyway, doing
'   it this way keeps the right table name in the .MDX file
'   so Paradox is happy.  I don't work with dBASE IV for
'   DOS so I can't guarantee dBASE IV will be happy with
'   the new files.  I'd appreciate it if someone could
'   tell me if dBASE IV is happy with a file packed with
'   this application.  It works with Visual Basic and
'   Paradox for Windows applications.)
'4. Create a new table and index with the same layout.
'5. Read all the records from the old table and write them
'   to the new table.  This skips all the deleted records.
'6. Delete the old table.
'
'This function requires 2 parameters:
' sDatabaseName contains the directory where your database
'    resides.  For example:  "C:\MYDBDIR"
' sTableName contains the name of your table (does not include
'    the .DBF extension).  For example:  "MYTABLE"
'
'An example implementation is the following code attached
'to a button that calls this function.  txtDatabase and
'txtTable are two text fields on a form where the user has
'entered a database directory and table name respectively.
'
'Sub cmdPack_Click ()
'    Dim sDatabase As String
'    Dim sTable As String
'    sDatabase = txtDatabase.Text
'    sTable = txtTable.Text
'    Call PackTable(sDatabase, sTable)
'End Sub
'
'Warning!!!  This routine works by copying all the records
'from your old file to a new file.  Therefore you must have
'enough room on your drive to hold a copy of your original file.
'The new file will be less than or equal to in size to your old
'file.  You must also have exclusive access to your table.
'I have set the database open to exclusive mode to ensure this.
'That means the best (and only) time to run this is when
'noone else is accessing the database.
'
'WARNING!!! IT IS ALWAYS A GOOD IDEA TO BACK UP YOUR DATAFILES
'BEFORE YOU TRY SOMETHING LIKE THIS.  IT NECESSARILY READS AND
'WRITES EVERY RECORD IN YOUR TABLE.  IT ALSO RENAMES FILES
'A COUPLE OF TIMES.  IF YOUR SYSTEM GLITCHES IN THE MIDDLE OF
'THIS OPERATION YOU COULD BE HUNG OUT TO DRY WITHOUT A BACKUP.
'USE THIS AT YOUR OWN RISK!!!!!!!!!!!
'
Sub PackTable (sDatabaseName As String, sTableName As String)

Dim tblNew      As Table
Dim tblOld      As Table
Dim tdfNew      As New TableDef
Dim tdfOld      As New TableDef
Dim dbDatabase  As Database
Dim idxNew      As New Index

Dim iIndex          As Integer
Dim iCountFields    As Integer
Dim iCountIndexes   As Integer

Dim sDBFFile As String
Dim sDBTFile As String
Dim sMDXFile As String
Dim sTmpDBFFile As String
Dim sTmpDBTFile As String
Dim sTmpMDXFile As String

'Put up a busy hourglass.
screen.MousePointer = 11

'Build the complete file names.
If Right$(sDatabaseName, 1) = "\" Then
    sDBFFile = sDatabaseName + sTableName
    sTmpDBFFile = sDatabaseName + "XXXXXXXX"
Else
    sDBFFile = sDatabaseName + "\" + sTableName
    sTmpDBFFile = sDatabaseName + "\XXXXXXXX"
End If
sDBTFile = sDBFFile + ".DBT"
sMDXFile = sDBFFile + ".MDX"
sTmpDBTFile = sTmpDBFFile + ".DBT"
sTmpMDXFile = sTmpDBFFile + ".MDX"
sTmpDBFFile = sTmpDBFFile + ".DBF"
sDBFFile = sDBFFile + ".DBF"

'Kill any existing temporary tables
'Kill XXXXXXXX.DBF
On Error GoTo NoXXXDBF
'MsgBox sTmpDBFFile, 0, "DEBUG - Killing:"
Kill sTmpDBFFile
GoTo XXXDBT

NoXXXDBF:
On Error GoTo 0
Resume XXXDBT

XXXDBT:
'Kill XXXXXXXX.DBT
On Error GoTo NoXXXDBT
'MsgBox sTmpDBTFile, 0, "DEBUG - Killing"
Kill sTmpDBTFile
GoTo XXXMDX

NoXXXDBT:
On Error GoTo 0
Resume XXXMDX

XXXMDX:
'Kill XXXXXXXX.MDX
On Error GoTo NoXXXMDX
'MsgBox sTmpMDXFile, 0, "DEBUG - Killing"
Kill sTmpMDXFile
GoTo EndXXX

NoXXXMDX:
On Error GoTo 0
Resume EndXXX

EndXXX:
On Error GoTo 0
'***** FINISHED DELETING EXISTING TEMP FILES ****

'Open the database.
'Open for exclusive use.  You will get an error here if someone
'already has the table open.  You can add some error checking
'here if you want.
Set dbDatabase = OpenDatabase(sDatabaseName, True, False, "dBASE IV;")

'Get table definition of the table.
Set tdfOld = dbDatabase.TableDefs(sTableName)

'Define fields - Get number of fields in table.
iCountFields = tdfOld.Fields.Count

'Set up an array of fields. (The array is 0 based.  Adjust
'the field count down by 1 for this.)
iCountFields = iCountFields - 1

'Use ReDim to dynamically size the array.  That way you don't
'have to arbitrarily set a maximum number of fields.
ReDim afldNewFields(iCountFields) As New field

'Now loop through all the field definitions of the old
'file and assign them to the new file.
For iIndex = 0 To iCountFields
    afldNewFields(iIndex).Name = tdfOld.Fields(iIndex).Name
    afldNewFields(iIndex).Type = tdfOld.Fields(iIndex).Type
    afldNewFields(iIndex).Size = tdfOld.Fields(iIndex).Size
    afldNewFields(iIndex).Attributes = tdfOld.Fields(iIndex).Attributes
    'The OrdinalPosition, SourceField, SourceTable, and Value
    'properties do not get set when you are creating the
    'table.  They are only valid when this is part of a
    'recordset.
Next

'Now duplicate the indexes.
iCountIndexes = tdfOld.Indexes.Count
'Adjust the count back one because the array is 0 based.
iCountIndexes = iCountIndexes - 1
If (iCountIndexes < 0) Then
    MsgBox "There Are No Indexes Defined!", 0, "Warning!"
    GoTo NoIndexes
End If

'Use ReDim to dynamically size the array.  That way you don't
'have to arbitrarily set a maximum number of indexes.
ReDim aidxNewIndexes(iCountIndexes) As New Index

For iIndex = 0 To iCountIndexes
    aidxNewIndexes(iIndex).Fields = tdfOld.Indexes(iIndex).Fields
    aidxNewIndexes(iIndex).Name = tdfOld.Indexes(iIndex).Name
    aidxNewIndexes(iIndex).Unique = tdfOld.Indexes(iIndex).Unique
    aidxNewIndexes(iIndex).Primary = tdfOld.Indexes(iIndex).Primary
Next

NoIndexes:

dbDatabase.Close

'**********************************************
'Rename all the existing files to the TEMP file
'names.  Then re-open the database.
'**********************************************
On Error GoTo NorDBFFile
Name sDBFFile As sTmpDBFFile
On Error GoTo 0
GoTo lblrMDXFile
NorDBFFile:
On Error GoTo 0
MsgBox "Error Renaming .DBF File to XXXXXXXX.DBF", 0, "ERROR!"
Resume lblrMDXFile

lblrMDXFile:
On Error GoTo NorMDXFile
Name sMDXFile As sTmpMDXFile
On Error GoTo 0
GoTo lblrDBTFile

NorMDXFile:
On Error GoTo 0
MsgBox "Error Renaming .MDX File to XXXXXXXX.MDX", 0, "ERROR!"
Resume lblrDBTFile

lblrDBTFile:
On Error GoTo NorDBTFile
Name sDBTFile As sTmpDBTFile
On Error GoTo 0
'Don't put up a warning here, there might not be an
'original .DBT file.
GoTo EndOfRename

NorDBTFile:
On Error GoTo 0
Resume EndOfRename

EndOfRename:
'***** FINISHED RENAMING EXISTING FILES *****

'Re-Open the database.
'Open for exclusive use.  You will get an error here if someone
'already has the table open.  You can add some error checking
'here if you want.
Set dbDatabase = OpenDatabase(sDatabaseName, True, False, "dBASE IV;")
'Now we have all the fields.
'Build the new tabledef.
'Set the name of the new table.
tdfNew.Name = sTableName
'Now append the fields to the table definition.
For iIndex = 0 To iCountFields
    tdfNew.Fields.Append afldNewFields(iIndex)
Next

'Now append the indexes to the new table.
If iCountIndexes >= 0 Then
    For iIndex = 0 To iCountIndexes
        tdfNew.Indexes.Append aidxNewIndexes(iIndex)
    Next
End If

'Now append the new table to the database
dbDatabase.TableDefs.Append tdfNew

'Open the new temporary table.
'NOTE:  I don't have any error checking on these opens.
Set tblOld = dbDatabase.OpenTable("XXXXXXXX")
'3 = DenyRead and DenyWrite to others.
Set tblNew = dbDatabase.OpenTable(sTableName, 3)
'Copy records from old to new
'Set order
tblOld.Index = ""
tblNew.Index = ""
'Make sure there are records.
If tblOld.RecordCount < 1 Then
    GoTo NoRecords
End If
tblOld.MoveFirst
Do
    'Keep going until you get to the end of the file.
    If tblOld.EOF Then
        Exit Do
    End If
    'Add a new record to the new table.
    tblNew.AddNew
    'Now put in all the data.
    For iIndex = 0 To iCountFields
        tblNew(tdfOld.Fields(iIndex).Name) = tblOld(tdfOld.Fields(iIndex).Name)
    Next
    'Now update the record.
    tblNew.Update
    'Get the next old record.
    tblOld.MoveNext
Loop

NoRecords:

'Close all the files.
tblOld.Close
tblNew.Close
dbDatabase.Close

'Delete all the old files.
On Error GoTo NoDBFFile
Kill sTmpDBFFile
On Error GoTo 0
GoTo lblMDXFile
NoDBFFile:
On Error GoTo 0
MsgBox "Error Deleting .DBF File", 0, "ERROR!"
Resume lblMDXFile

lblMDXFile:
On Error GoTo NoMDXFile
Kill sTmpMDXFile
On Error GoTo 0
GoTo lblDBTFile

NoMDXFile:
On Error GoTo 0
MsgBox "Error Deleting .MDX File", 0, "ERROR!"
Resume lblDBTFile

lblDBTFile:
On Error GoTo NoDBTFile
Kill sTmpDBTFile
On Error GoTo 0
'Don't put up a warning here, there might not be an
'original .DBT file.
GoTo EndOfSub

NoDBTFile:
On Error GoTo 0
Resume EndOfSub

EndOfSub:
'Put the mouse pointer back to normal.
screen.MousePointer = 0
MsgBox ("Pack Completed")
Exit Sub


End Sub