[AccessD] packing a dbf from within Access 97

On Mon, 21 Mar 2005 11:03:25 -0400, Boogie Loogie
<boogieloogie at gmail.com> wrote:
> On Fri, 18 Mar 2005 22:09:36 -0000, Andy Lacey
> <andy at minstersystems.co.uk> wrote:
> > Hi BL
> > Presumably if you're using a dbf you have Clipper, Foxpro or something which
> > maintains it. Couldn't you write a small EXE in one of those and Shell to
> > it?
> >
> > -- Andy Lacey
> > http://www.minstersystems.co.uk
> 
> Actually I do not have that. The GIS and GPS software I use read and
> write shapefiles...a native format. A shapefile has numerous ( for
> lack of a better term) subfiles one of which is a dbf.
> 
> Anyway stay tuned I am working on a utility with Access. I will post
> it here when I am done.
> 
> Cheers
> 
> BL
> 

FOR ACCESS 97:

Ok I have a rough draft of a packing utility. Some of the code came
from M$ web site and some from Experts-Exchange.

Opinions, improvements are welcomed. Basically the code replaces the
dbf with a new table with all of the 'junk' removed. It appears to be
working for me in my inital tests.

STEP 1:
In a new form create a combobox called cboTables

STEP 2:
in the rowsource of cboTables place the following:

SELECT MsysObjects.Name FROM MsysObjects WHERE
(((Left([Name],1))<>'~') AND ((Left([Name],4))<>'Msys') AND
((MsysObjects.Type)=6));

STEP 3:
Place a command button on the same form as cboTables and place this
code behind it:

Private Sub Command2_Click()
On Error GoTo Packman
Dim db As Database
Set db = CurrentDb()
If IsNull(Me!cboTables) Then
    Beep
    MsgBox "Select a table", vbInformation
    Me!cboTables.SetFocus
    Exit Sub
End If
Call rackempackem(db, Me!cboTables)
Exit Sub

Packman:
MsgBox Error$
Exit Sub

PackEnd:
End Sub

STEP 4:
Create a new module with the following:

Function tInstrRev(string1 As String, string2 As String)
Dim tPos As Long

tPos = InStr(1, string1, string2)
While InStr(tPos + 1, string1, string2) <> 0
tPos = InStr(tPos + 1, string1, string2)
Wend
tInstrRev = tPos
End Function

STEP 5: 
Create a new module with the following:

Public Sub rackempackem(db As Database, tblname As String)
     Const MB_YESNO = 4                     ' Yes and No buttons
     Const MB_ICONEXCLAMATION = 48          ' Warning message
     Const IDYES = 6                        ' Yes button pressed

     Dim dbdir As String, tmp As String 'Temp variables
     Dim i As Integer, ret As Integer   'Counter and return value of MsgBox
     Dim tdf As TableDef
     Dim flags As Integer                   'Flags for MsgBox
     ReDim idxs(0) As New Index             'Holds indexes

     On Error GoTo PackErr
     
     flags = MB_YESNO Or MB_ICONEXCLAMATION
     ret = MsgBox("Do you want to pack " & tblname & ".dbf?", flags)
     If ret = IDYES Then
       dbdir = Left$(db.Name, tInstrRev(db.Name, "\"))  'Hold database directory

       'Delete the temp file if it exists.
       If Dir$(dbdir & "p_a_c_k.*") <> "" Then
         Kill dbdir & "p_a_c_k.*"
       End If
       
       For Each tdf In db.TableDefs
        If tdf.Name = "p_a_c_k" Then
            db.Execute "DROP TABLE p_a_c_k;"
        End If
       Next
       'Store the indexes.
       For i = 0 To db.TableDefs(tblname).Indexes.Count - 1
         ReDim Preserve idxs(i + 1)
         idxs(i).Name = db.TableDefs(tblname).Indexes(i).Name
         idxs(i).Fields = db.TableDefs(tblname).Indexes(i).Fields
         idxs(i).Primary = db.TableDefs(tblname).Indexes(i).Primary
         idxs(i).Unique = db.TableDefs(tblname).Indexes(i).Unique
       Next

       'Create the new table without the deleted records.
       db.Execute "Select * into [p_a_c_k] from " & tblname

       'Delete the current table.
       'delete all records
       db.Execute "DELETE *.* from " & tblname
       db.TableDefs.Delete tblname

       'Rename the DBF file and any memo files.
       tmp = Dir$(dbdir & "p_a_c_k.*")
       Do While tmp <> ""
       'Rename with the correct file extension; this should be on one line.

           Name dbdir & tmp As dbdir & tblname & Right$(tmp, Len(tmp)
- InStr(tmp, ".") + 1)
           tmp = Dir$
       Loop

       'Refresh the tabledefs and add the indexes to the new table.
       db.TableDefs.Refresh
       For i = 0 To UBound(idxs) - 1
         db.TableDefs(tblname).Indexes.Append idxs(i)
       Next

       MsgBox "'" & tblname & "' .dbf successfully Packed!", MB_ICONEXCLAMATION
       DoCmd.TransferDatabase acExport, "dBase 5.0", "C:\GIS\SILVI\",
acTable, "P_A_C_K", tblname 'change path to suit your needs
       'db.Execute "DROP TABLE P_A_C_K;" 'optional
       DoCmd.TransferDatabase acLink, "dBase 5.0", "C:\GIS\SILVI\",
acTable, tblname, tblname 'change path to suit your needs
            
     End If
     RefreshDatabaseWindow
     Exit Sub

PackErr:
MsgBox Error$
Exit Sub

PackEnd:
End Sub

Hopefully this is useful to someone.