home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / tool / prg_sup / pwrtbl / compact.bas < prev    next >
BASIC Source File  |  1994-08-21  |  4KB  |  144 lines
  1. Option Explicit
  2.  
  3. ' Simple function to add a new index to an openeded database
  4. ' ---------------------------------------------------------
  5. Function db_addindex% (db As Database, tablename$, ixn$, ixf$, ixu%, ixp%)
  6.     Dim nindx As New Index
  7.     On Error Resume Next
  8.     Err = False
  9.     If Len(ixn) = 0 Or Len(ixf) = 0 Then
  10.        db_addindex = True
  11.        Exit Function
  12.     End If
  13.     nindx.Name = ixn
  14.     nindx.Fields = ixf
  15.     nindx.Primary = ixp
  16.     nindx.Unique = ixu
  17.     
  18.     db.TableDefs(tablename).Indexes.Append nindx
  19.     
  20.     If Err Then
  21.        MsgBox Error$ & Chr$(13) & "Table: " & tablename & Chr$(13) & "Index: " & ixn, 48
  22.     Else
  23.        db_addindex = True
  24.     End If
  25. End Function
  26.  
  27. ' --------------------------------------------------------
  28. ' dbf_compactdatabase dBName$
  29. ' --------------------------------------------------------
  30. ' Compacts an entire xBase database (dBase IV/FoxPro 2.5)
  31. '
  32. ' Arguments:
  33. '           dBName  - Name/Directory of the database
  34. '           dBC     - Connect (dBase IV or FoxPro 2.5)
  35. '
  36. ' Returns:
  37. '           Bool    - True if successful
  38. '
  39. '
  40. ' ==> Make sure that the database can be opened for exlusive
  41. '     usage!!!
  42. '
  43. Function dbf_compactDatabase% (dbName$, dbc$)
  44.     Dim db As Database
  45.     Dim tn$, i%
  46.  
  47.     On Error Resume Next
  48.     Err = False
  49.     
  50.     For i = 0 To 10000
  51.         Err = False
  52.         Set db = OpenDatabase(dbName$, True, False, dbc)
  53.         If Err Then
  54.            MsgBox Error$, 48
  55.            Exit For
  56.         End If
  57.         If i + 1 > db.TableDefs.Count Then Exit For
  58.         tn = db.TableDefs(i).Name
  59.         db.Close
  60.         If dbf_compactTable(dbName, dbc, tn) = False Then Exit Function
  61.     Next
  62.     dbf_compactDatabase = True
  63. End Function
  64.  
  65. ' --------------------------------------------------------
  66. ' dbf_compactTable dBName$, tableName$
  67. ' --------------------------------------------------------
  68. ' Compacts a xBase table (dBase IV/FoxPro 2.5)
  69. '
  70. ' Arguments:
  71. '           dBName      - Name/Directory of the database
  72. '           dBC         - Connect (dBase IV or FoxPro 2.5)
  73. '           tableName   - Name of the table
  74. '
  75. ' Returns:
  76. '           Bool    - True if successful
  77. '
  78. '
  79. ' ==> Make sure that the database can be opened for exlusive
  80. '     usage!!!
  81. '
  82. Function dbf_compactTable% (ByVal dbPath$, dbc$, tablename$)
  83.     Dim db As Database, iSuf$, mSuf$
  84.     Dim ox As Indexes, oxc%, i%
  85.     
  86.     On Error Resume Next
  87.     Err = False
  88.     Set db = OpenDatabase(dbPath, True, False, dbc)
  89.     If Err Then
  90.        MsgBox Error$, 48
  91.        Exit Function
  92.     End If
  93.     If LCase$(dbc) = "dbase iv;" Then
  94.        iSuf = ".MDX"
  95.        mSuf = ".DBT"
  96.     Else
  97.        iSuf = ".CDX"
  98.        mSuf = ".FPT"
  99.     End If
  100.     
  101.     If Right$(dbPath, 1) <> "\" Then dbPath = dbPath & "\"
  102.     GoSub dbComp_killTemp
  103.     
  104.     screen.MousePointer = 11
  105.     db.Execute ("SELECT * INTO temptbl0 from " & tablename)
  106.     If Err Then
  107.        MsgBox Error$, 48
  108.        GoTo dbComp_exit
  109.     End If
  110.  
  111.     Set ox = db.TableDefs(tablename).Indexes
  112.     oxc = ox.Count - 1
  113.     For i = 0 To oxc
  114.         If db_addindex(db, "temptbl0", CStr(ox(i).Name), CStr(ox(i).Fields), CInt(ox(i).Unique), CInt(ox(i).Primary)) = False Then
  115.            GoTo dbComp_exit
  116.         End If
  117.     Next
  118.     If Err = False Then
  119.        Kill dbPath & tablename & ".DBF"
  120.        Kill dbPath & tablename & mSuf
  121.        Kill dbPath & tablename & iSuf
  122.        Name dbPath & "temptbl0" & iSuf As dbPath & tablename & iSuf
  123.        Name dbPath & "temptbl0.dbf" As dbPath & tablename & ".DBF"
  124.        Name dbPath & "temptbl0" & mSuf As dbPath & tablename & mSuf
  125.        GoSub dbComp_killTemp
  126.     End If
  127.  
  128.     dbf_compactTable = True
  129.  
  130. dbComp_exit:
  131.     db.Close
  132.     screen.MousePointer = 0
  133.     Exit Function
  134.  
  135. dbComp_killTemp:
  136.     Kill dbPath & "temptbl0.dbf"
  137.     Kill dbPath & "temptbl0" & mSuf
  138.     Kill dbPath & "temptbl0" & iSuf
  139.     Err = False
  140.     Return
  141.  
  142. End Function
  143.  
  144.