paradox table pack de exception

[mege]

Borlandın sitesinden zamanında aşağıadki kod ile tabloyu otomatik re-pack işlemi yaptırmak istiyorum.
ama tablo kapalı olmasına rağmen şu satırda
Chk(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));
table is busy hatası veriyor

neden başarısız oluyorum acaba
telekkürşer

Kod: Tümünü seç

procedure TTablePack.PackParadoxTable;

var
  { Specific information about the table structure, indexes, etc. }
  TblDesc: CRTblDesc;
  { Uses as a handle to the database }
  hDb: hDbiDb;
  { Path to the currently opened table }
  TablePath: array[0..dbiMaxPathLen] of char;

begin
  { Initialize the table descriptor }
  FillChar(TblDesc, SizeOf(CRTblDesc), 0);
  with TblDesc do
  begin
    { Place the table name in descriptor }
    StrPCopy(szTblName, TableName);
    { Place the table type in descriptor }
    StrCopy(szTblType, GetTableType);
    { Set the packing option to true }
    bPack := True;
  end;
  { Initialize the DB handle }
  hDb := nil;
  { Get the current table's directory.  This is why the table MUST be
    opened until now }
  Chk(DbiGetDirectory(DBHandle, True, TablePath));
  { Close the table }
  Close;
  { NOW: since the DbiDoRestructure call needs a valid DB handle BUT the
    table cannot be opened, call DbiOpenDatabase to get a valid handle.
    Just leaving Active = FALSE does not give you a valid handle }
  Chk(DbiOpenDatabase(nil, 'STANDARD', dbiReadWrite, dbiOpenExcl, nil,
                        0, nil, nil, hDb));
  { Set the table's directory to the old directory }
  Chk(DbiSetDirectory(hDb, TablePath));
  { Pack the PARADOX table }
  Chk(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));
  { Close the temporary database handle }
  Chk(DbiCloseDatabase(hDb));
  { Re-Open the table }
  Open;
end;

[gkimirti]

Pack ve Repair icin ben bir free bilesen bulmustum basit bisiy
tek dezavantajı TUtil32.dll e ihtiyac duyması
sayfası kapandıgı icin buraya atıyorum bilesen kodlarını
TUtil32.dll icindeki function tanımları TUtil32.pas icinde yapılmıs

Kod: Tümünü seç

unit TUtil32;

interface

uses Bde, DbiTypes;

{ TUtility (TUVerifyTable) Session Options }
const
  TU_Append_Errors = 1;
  TU_No_Secondary  = 2;
  TU_No_Warnings   = 4;
  TU_Header_Only   = 8;
  TU_Dialog_Hide   = 16;
  TU_No_Lock       = 32;

{ TUtility type definitions }
type
  hTUses  = Word;
  phTUses = ^hTUses;
  { Verify Callback processes }
  TUVerifyProcess = (TUVerifyHeader, TUVerifyIndex, TUVerifyData, TUVerifySXHeader,
                     TUVerifySXIndex, TUVerifySXData, TUVerifySXIntegrity,
                     TUVerifyTableName, TURebuild);
  { Call back info for Verify Callback function }
  TUVerifyCallBack = record
    PercentDone: word;
    TableName: DBIPath;
    Process: TUVerifyProcess;
    CurrentIndex: word;
    TotalIndex: word;
  end;

{ TUtility functions }
function TUInit(var hTUSession: hTUses): DBIResult;  stdcall;

function TUVerifyTable(hTUSession: hTUses;
                       pszTableName,
                       pszDriverType,
                       pszErrTableName,
                       pszPassword: PChar;
                       iOptions: integer;
                       var piErrorLevel: Integer): DBIResult; stdcall;

function TURebuildTable(hTUSession: hTUses;
                        pszTableName,
                        pszDriverType,
                        pszBackupTableName,
                        pszKeyviolName,
                        pszProblemTableName: PChar;
                        pCrDesc: pCRTblDesc): DBIResult; stdcall;

function TUGetCRTblDescCount(hTUSession: hTUses;
                             pszTableName: PChar;
                             var iFldCount,
                             iIdxCount,
                             iSecRecCount,
                             iValChkCount,
                             iRintCount,
                             iOptParams,
                             iOptDataLen: word): DBIResult; stdcall;

function TUFillCRTblDesc(hTUSession: hTUses;
                         pCrDesc: pCRTblDesc;
                         pszTableName,
                         pszPassword: PChar): DBIResult; stdcall;

function TUFillCURProps(hTUSession: hTUses;
                        pszTableName: PChar;
                        var tblProps: CURProps): DBIResult; stdcall;

function TUGetExtTblProps(hTUSession: hTUses;
                          pszTableName: PChar;
                          var pTS: TimeStamp;
                          var pbReadOnly: Boolean): DBIResult; stdcall;

function TUExit(hTUSession: hTUses): DBIResult; stdcall;

function TUGetErrorString(iErrorcode: DBIResult;
                          pszError: PChar): DBIResult; stdcall;

implementation

const
  TU32 = 'TUTIL32.DLL';

function TUInit;              external TU32 name 'TUInit';
function TUVerifyTable;       external TU32 name 'TUVerifyTable';
function TURebuildTable;      external TU32 name 'TURebuildTable';
function TUGetCRTblDescCount; external TU32 name 'TUGetCRTblDescCount';
function TUFillCRTblDesc;     external TU32 name 'TUFillCRTblDesc';
function TUFillCURProps;      external TU32 name 'TUFillCURProps';
function TUGetExtTblProps;    external TU32 name 'TUGetExtTblProps';
function TUExit;              external TU32 name 'TUExit';
function TUGetErrorString;    external TU32 name 'TUGetErrorString';

end.

Bileşen Kodları

Kod: Tümünü seç

unit KPdxRpr;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  TUtil32, DB, DbTables, BDE;

type

  EPdxRepair = class(Exception)
  end;

  TPRCheckAction = (caIgnore, caAbort, caRepair);
  TPRCheckStatus = (csTableOK, csTableError, csCheckFault);
  TPRRepairStatus = (rsTableRepaired, rsRepairFault);

  TPdxRepairEvent = procedure(TblName : string) of object;
  TPRCheckEvent = procedure(TblName : string; Status : TPRCheckStatus; var Action : TPRCheckAction) of object;
  TPRRepairEvent = procedure(TblName : string; Status : TPRRepairStatus) of object;

  TKPdxRepair = class(TComponent)
  private
    vhTSes: hTUSes;
    FCheckResult : integer;
    FTempDir : string;
    FDBDir : string;
    FDatabaseName : string;
    FBeforeTableCheck : TPdxRepairEvent;
    FBeforeTableRepair : TPdxRepairEvent;
    FOnCheckTable : TPRCheckEvent;
    FOnRepairTable : TPRRepairEvent;

    function GetTableFile(const TblName : string) : string;
    function GetTempFile(const FName : string) : string;

    procedure SetDatabaseName(AValue : string);
  protected
  public
    constructor Create(AOwner : TComponent);override;

    function CheckTable(TblName : string) : boolean;
    function RepairTable(TblName : string) : boolean;
    procedure CheckRepairDB;

    property CheckResult : integer read FCheckResult;
  published
    property DatabaseName : string read FDatabaseName write SetDatabaseName;
    property TempDir : string read FTempDir write FTempDir;
    property BeforeTableCheck : TPdxRepairEvent read FBeforeTableCheck write FBeforeTableCheck;
    property BeforeTableRepair : TPdxRepairEvent read FBeforeTableRepair write FBeforeTableRepair;
    property OnCheckTable : TPRCheckEvent read FOnCheckTable write FOnCheckTable;
    property OnRepairTable : TPRRepairEvent read FOnRepairTable write FOnRepairTable;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Data Access', [TKPdxRepair]);
end;

constructor TKPdxRepair.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Session.Active := true;
  FDatabaseName := '';
  FBeforeTableCheck := nil;
  FBeforeTableRepair := nil;
  FOnCheckTable := nil;
  FOnRepairTable := nil;
  FTempDir := '';
  FDBDir := '';
end;

procedure TKPdxRepair.SetDatabaseName(AValue : string);
var
  vDBDesc: DBDesc;
begin
 FDatabaseName := AValue;
 Check(DbiGetDatabaseDesc(PChar(FDatabaseName), @vDBDesc));
 FDBDir := vDBDesc.szPhyName;
end;

function TKPdxRepair.GetTableFile(const TblName : string) : string;
begin
  Result := Format('%s\%s', [FDBDir, TblName]);
end;

function TKPdxRepair.GetTempFile(const FName : string) : string;
begin
  if FTempDir = ''
  then Result := FName
  else Result := FTempDir + '\' + FName;
end;

function TKPdxRepair.CheckTable(TblName : string) : boolean;
var
  Table : string;
  CheckTbl : string;
begin
  CheckTbl := GetTempFile('check.db');
  Screen.Cursor := crHourGlass;
  try
    Check(TUInit(vHtSes));
    try
      Table := GetTableFile(Tblname);
      if TUVerifyTable(vhTSes, PChar(Table), szPARADOX, PChar(CheckTbl),
           nil, 0, FCheckResult) = DBIERR_NONE
      then begin
        if FCheckResult = 0
        then Result := true
        else Result := false

{      case Msg of
        0: MessageLB.Caption := 'Verification Successful. Table has no errors.';
        1: MessageLB.Caption := 'Verification Successful. Verification completed.';
        2: MessageLB.Caption := 'Verification Successful. Verification could not be completed.';
        3: MessageLB.Caption := 'Verification Successful. Table must be rebuild manually.';
        4: MessageLB.Caption := 'Verification Successful. Table cannot be rebuilt.';
       end;}
      end
      else begin
//        MessageLB.Caption := 'Verification unsuccessful.';
       FCheckResult := 5;
       Result := false;
      end;
    finally
     Check(TUExit(vHtSes));
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

function TKPdxRepair.RepairTable(TblName : string) : boolean;
var
  iFld, iIdx, iSec, iVal, iRI, iOptP, iOptD: word;
  rslt: DBIResult;
  TblDesc: CRTBlDesc;
  Table, BckpTbl, RbldTbl, KeyvTbl, ProblemTbl : String;
begin
  Screen.Cursor := crHourGlass;
  BckpTbl := GetTempFile('backup.db');
  RbldTbl := GetTempFile('Rebuild.db');
  KeyvTbl := GetTempFile('keyviol.db');
  ProblemTbl := GetTempFile('problem.db');
  try
    Check(TUInit(vHtSes));
    try
      Table := GetTableFile(TblName);
      rslt := TUGetCRTblDescCount(vhTSes, PChar(Table), iFld,
            iIdx, iSec, iVal, iRI, iOptP, iOptD);
      if rslt = DBIERR_NONE then begin
        FillChar(TblDesc, SizeOf(CRTBlDesc), 0);
        StrPCopy(TblDesc.szTblName, szTable);
        TblDesc.szTblType := szParadox;
        StrPCopy(TblDesc.szErrTblName, RbldTbl);

        TblDesc.iFldCount := iFld;
        GetMem(TblDesc.pFldDesc, (iFld * SizeOf(FldDesc)));

        TblDesc.iIdxCount := iIdx;
        GetMem(TblDesc.pIdxDesc, (iIdx * SizeOf(IdxDesc)));

        TblDesc.iSecRecCount := iSec;
        GetMem(TblDesc.pSecDesc, (iSec * SizeOf(SecDesc)));

        TblDesc.iValChkCount := iVal;
        GetMem(TblDesc.pvchkDesc, (iVal * SizeOf(VCHKDesc)));

        TblDesc.iRintCount := iRI;
        GetMem(TblDesc.printDesc, (iRI * SizeOf(RINTDesc)));

        TblDesc.iOptParams := iOptP;
        GetMem(TblDesc.pfldOptParams, (iOptP * sizeOf(FLDDesc)));

        GetMem(TblDesc.pOptData, (iOptD * DBIMAXSCFLDLEN));
        try
           rslt := TUFillCRTblDesc(vhTSes, @TblDesc, PChar(Table), nil);
           if rslt = DBIERR_NONE then begin
             if TURebuildTable(vhTSes, PChar(Table), szPARADOX,
                 PChar(BckpTbl), PChar(KeyvTbl), PChar(ProblemTbl), @TblDesc) = DBIERR_NONE
             then Result := true
             else Result := false;
           end
           else Result := false;

        finally
          FreeMem(TblDesc.pFldDesc, (iFld * SizeOf(FldDesc)));
          FreeMem(TblDesc.pIdxDesc, (iIdx * SizeOf(IdxDesc)));
          FreeMem(TblDesc.pSecDesc, (iSec * SizeOf(SecDesc)));
          FreeMem(TblDesc.pvchkDesc, (iVal * SizeOf(VCHKDesc)));
          FreeMem(TblDesc.printDesc, (iRI * SizeOf(RINTDesc)));
          FreeMem(TblDesc.pfldOptParams, (iOptP * sizeOf(FLDDesc)));
          FreeMem(TblDesc.pOptData, (iOptD * DBIMAXSCFLDLEN));
        end;
      end;
    finally
     Check(TUExit(vHtSes));
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TKPdxRepair.CheckRepairDB;
var
  slTables : TStrings;
  i : integer;
  CS : TPRCheckStatus;
  CA : TPRCheckAction;
  RS : TPRRepairStatus;
begin
  slTables := TStringList.Create;
  try
    Session.GetTableNames(FDatabaseName,'*.db',true,false,slTables);
    for i := 0 to slTables.Count-1 do begin
      if Assigned(FBeforeTableCheck) then FBeforeTableCheck(slTables[i]);
      CheckTable(slTables[i]);
      if FCheckResult = 0
      then begin CS := csTableOK;CA := caIgnore; end;
      if FCheckResult in [1..4]
      then begin CS := csTableError;CA := caRepair; end;
      if FCheckResult = 5
      then begin CS := csCheckFault;CA := caAbort; end;
      if Assigned(FOnCheckTable) then FOnCheckTable(slTables[i], CS, CA);
      if (CS = csTableError) and (CA = caRepair) then begin
        if Assigned(FBeforeTableRepair) then FBeforeTableRepair(slTables[i]);
        if RepairTable(slTables[i])
        then RS := rsTableRepaired
        else RS := rsRepairFault;
        if Assigned(FOnRepairTable) then FOnRepairTable(slTables[i], RS);
      end
      else if CA = caAbort then break;
    end;
  finally
    slTables.Free;
  end;
end;

end.

Kodları inceleyerek fonksiyon sekline de getirebilirsin
ben oldugu gibi kullanmıstım ise yaradı.

[mege]

Gökmen hocam çok teşekkürler, ama problem gerçekten tablonun açık olması imiş , başka bir auto created formadaki bi listem tablodan bilgi çekiyordu o hep açık kalıyormuş, onuda kapatınca halloldu.

kodun son kesilmiş hali
koddaki table1 yerine bi fonksiyondanda tablo ismi gönderilebilir.

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
var TblName : String;
    TablePath : array[0..50] of char;
    TblDesc : CRTblDesc;
    hDb     : hDbiDb;
    Table   : TTable;
begin
Table:= Table1;
Table.Close;
Application.ProcessMessages;
FillChar(TblDesc, SizeOf(CRTblDesc), 0);
TblName:= Table.TableName;
with TblDesc do
  begin
  StrPCopy(szTblName, Table.TableName);
  StrCopy(szTblType, szParadox);
  bPack := True;
  end;
hDb := nil;
Table.Open;
Check(DbiGetDirectory(Table.DBHandle, True, TablePath));
Table.Close;
Check(DbiOpenDatabase(nil, 'STANDARD', dbiReadWrite, dbiOpenExcl, nil,
                        0, nil, nil, hDb));
Check(DbiSetDirectory(hDb, TablePath));
Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));
Check(DbiCloseDatabase(hDb));
Application.ProcessMessages;
Table.Open;
Table.Close;

end;