tutil.pas

RxRich很有用的文字图像显示控件,这是它的Demo

    if I in FVerifyOptions then Result := Result or VerifyFlags[I];
end;

procedure TTUtility.SetTabName(const TabName: string; const Dest: DBIPATH);
var
  P: PChar;
begin
  P := @Dest;
  if ChangeFileExt(TabName, '') <> StrPas(Dest) then begin
    if TabName <> '' then
      StrPLCopy(Dest, AnsiUpperCase(ChangeFileExt(TabName, '')),
        SizeOf(Dest) - 1)
    else FillChar(P^, SizeOf(Dest), #0);
  end;
end;

function TTUtility.GetPassword: string;
begin
  Result := StrPas(FPassword);
end;

procedure TTUtility.SetPassword(const Value: string);
begin
  if Value <> Password then begin
    if Value <> '' then
      StrPLCopy(FPassword, Value, SizeOf(FPassword) - 1)
    else FillChar(FPassword, SizeOf(FPassword), 0);
  end;
end;

function TTUtility.GetCheckErrorTable: string;
begin
  Result := StrPas(FCheckErrorTable);
end;

procedure TTUtility.SetCheckErrorTable(const Value: string);
begin
  SetTabName(Value, FCheckErrorTable);
end;

function TTUtility.GetErrorTable: string;
begin
  Result := StrPas(FErrorTable);
end;

procedure TTUtility.SetErrorTable(const Value: string);
begin
  SetTabName(Value, FErrorTable);
end;

function TTUtility.GetProblemTable: string;
begin
  Result := StrPas(FProblemTable);
end;

procedure TTUtility.SetProblemTable(const Value: string);
begin
  SetTabName(Value, FProblemTable);
end;

function TTUtility.GetKeyViolationTable: string;
begin
  Result := StrPas(FKeyViolationTable);
end;

procedure TTUtility.SetKeyViolationTable(const Value: string);
begin
  SetTabName(Value, FKeyViolationTable);
end;

function TTUtility.GetBackupTable: string;
begin
  Result := StrPas(FBackupTable);
end;

procedure TTUtility.SetBackupTable(const Value: string);
begin
  SetTabName(Value, FBackupTable);
end;

function TTUtility.GetTableName: string;
begin
  Result := StrPas(FTableName);
end;

procedure TTUtility.SetTableName(const Value: string);
begin
  SetTabName(Value, FTableName);
end;

function TTUtility.ShowPasswordDialog: Boolean;
var
  S: string;
begin
  S := Password;
  Result := InputQuery(STUPwDlgCaption, Format(STUPwDlgPrompt,
    [ExtractFileName(TableName)]), S);
  if Result then Password := S;
end;

procedure TTUtility.FillTblDesc;
begin
  FillChar(FTblDesc, SizeOf(FTblDesc), 0);
  Check(TUGetCRTblDescCount(FSession, FTableName, FTblDesc.iFldCount,
    FTblDesc.iIdxCount, FTblDesc.iSecRecCount, FTblDesc.iValChkCount,
    FTblDesc.iRintCount, FTblDesc.iOptParams, FOptDataLen));
  StrPCopy(FTblDesc.szTblName, TableName);
  StrCopy(FTblDesc.szTblType, szPARADOX);
  StrPCopy(FTblDesc.szErrTblName, ErrorTable);
  GetMem(FTblDesc.pFldDesc, FTblDesc.iFldCount * SizeOf(FldDesc));
  GetMem(FTblDesc.PIdxDesc, FTblDesc.iIdxCount * SizeOf(IdxDesc));
  GetMem(FTblDesc.pSecDesc, FTblDesc.iSecRecCount * SizeOf(SecDesc));
  GetMem(FTblDesc.pVchkDesc, FTblDesc.iValChkCount * SizeOf(VchkDesc));
  GetMem(FTblDesc.pRintDesc, FTblDesc.iRintCount * SizeOf(RintDesc));
  GetMem(FTblDesc.pfldOptParams, FTblDesc.iOptParams * SizeOf(FldDesc));
  GetMem(FTblDesc.pOptData, FOptDataLen * DBIMAXSCFLDLEN);
  try
    while not CheckOpen(TUFillCRTblDesc(FSession, @FTblDesc, FTableName,
      FPassword)) do {Retry};
  except
    ClearTblDesc;
    raise;
  end;
end;

procedure TTUtility.ClearTblDesc;
begin
  if FTblDesc.pFldDesc <> nil then
    FreeMem(FTblDesc.pFldDesc, FTblDesc.iFldCount * SizeOf(FldDesc));
  if FTblDesc.PIdxDesc <> nil then
    FreeMem(FTblDesc.PIdxDesc, FTblDesc.iIdxCount * SizeOf(IdxDesc));
  if FTblDesc.pSecDesc <> nil then
    FreeMem(FTblDesc.pSecDesc, FTblDesc.iSecRecCount * SizeOf(SecDesc));
  if FTblDesc.pVchkDesc <> nil then
    FreeMem(FTblDesc.pVchkDesc, FTblDesc.iValChkCount * SizeOf(VchkDesc));
  if FTblDesc.pRintDesc <> nil then
    FreeMem(FTblDesc.pRintDesc, FTblDesc.iRintCount * SizeOf(RintDesc));
  if FTblDesc.pFldOptParams <> nil then
    FreeMem(FTblDesc.pFldOptParams, FTblDesc.iOptParams * SizeOf(FldDesc));
  if FTblDesc.pOptData <> nil then
    FreeMem(FTblDesc.pOptData, FOptDataLen * DBIMAXSCFLDLEN);
  FillChar(FTblDesc, SizeOf(FTblDesc), 0);
end;

procedure TTUtility.DoRepairTable;
var
  CurProp: CURProps;
  PasswordEmpty: Boolean;
begin
  if TableName = '' then Exit;
  while not CheckOpen(TUFillCURProps(FSession, FTableName,
    @CurProp)) do {Retry};
  PasswordEmpty := Password = '';
  if CurProp.bProtected and PasswordEmpty then
    if not ShowPasswordDialog then
      Exit; { no password specified - no repair }
  try
    VerifyTable;
    FillTblDesc;
    try
      Screen.Cursor := crHourGlass;
      try
{$IFNDEF WIN32}
        CheckBackupTable;
{$ENDIF}
        while not CheckOpen(TURebuildTable(FSession, FTableName,
          szPARADOX, FBackupTable, FKeyViolationTable, FProblemTable,
          @FTblDesc)) do {Retry};
      finally
        Screen.Cursor := crDefault;
      end;
    finally
      ClearTblDesc;
    end;
  finally
    if PasswordEmpty then Password := '';
  end;
end;

function TTUtility.VerifyTable: Cardinal;
begin
  CheckTU;
  { TUtility must be re-initialized for each verification }
  Check(TUExit(FSession));
  Check(TUInit(@FSession));
  Screen.Cursor := crHourGlass;
  try
    while not CheckOpen(TUVerifyTable(FSession, FTableName, szPARADOX,
      FCheckErrorTable, FPassword, VerifyFlag, Result)) do {Retry};
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TTUtility.DoCheckTable;

  function TabName: string;
  begin
    Result := ExtractFileName(ChangeFileExt(TableName, '.DB'));
  end;

var
  ErrMsg: string;
begin
  if TableName = '' then Exit;
  case VerifyTable of
    VFE_WARNING: if FShowNoError then
      MessageDlg(Format(STUVerifyOk, [TabName]), mtInformation, [mbOk], 0);
    VFE_DAMAGE_VERIFY, VFE_DAMAGE_NOT_VERIFY:
      begin
        ErrMsg := TULastErrorMessage;
        case FCheckRepair of
          crNoRepair: MessageDlg(ErrMsg + Format(STUDamage, [TabName]),
            mtError, [mbOk], 0);
          crAutoRepair: RepairTable;
          crConfirmRepair:
            if MessageDlg(ErrMsg + Format(STURebuild, [TabName]),
              mtError, [mbYes, mbNo], 0) = mrYes then
              RepairTable;
        end;
      end;
    VFE_REBUILD_MANUALLY:
      begin
        ErrMsg := TULastErrorMessage;
        MessageDlg(ErrMsg + Format(STURebuildManual, [TabName]), mtError,
          [mbOk], 0);
      end;
    VFE_CANNOT_REBUILD:
      begin
        ErrMsg := TULastErrorMessage;
        MessageDlg(ErrMsg + Format(STUNoRebuild, [TabName]), mtError,
          [mbOk], 0);
      end;
  end;
end;

procedure TTUtility.CheckTable;
begin
  RunTUtility(DoCheckTable);
end;

procedure TTUtility.RepairTable;
begin
  RunTUtility(DoRepairTable);
end;

function TTUtility.TULastErrorMessage: string;
var
  Table: TTable;
begin
  Result := '';
  if CheckErrorTable = '' then Exit;
  Table := TTable.Create(Application);
  try
    Table.TableName := ChangeFileExt(CheckErrorTable, '.DB');
    try
      Table.Open;
      Table.Last;
      Result := Table.FieldByName('Error Message').AsString;
      if Result <> '' then Result := Result + '. ';
    except
      Result := '';
    end;
  finally
    Table.Free;
  end;
  if Result = '' then Result := STUVerifyComplete;
end;

procedure TTUtility.DropErrorTable;
begin
  if CheckErrorTable = '' then Exit;
  with TTable.Create(Application) do
  try
    TableName := ChangeFileExt(CheckErrorTable, '.DB');
    if FileExists(TableName) then DeleteTable;
  finally
    Free;
  end;
end;

procedure TTUtility.CheckBackupTable;
var
  TabPath: string;
begin
  TabPath := ChangeFileExt(TableName, '');
  if TabPath <> '' then begin
    Delete(TabPath, Length(TabPath), 1);
    BackupTable := TabPath + '_.DB';
  end else BackupTable := '';
end;

procedure TTUtility.DefaultBackupNames;
var
  TabPath: string;
begin
  TabPath := NormalDir(GetEnvVar('TEMP'));
  if (TabPath = '') then
    TabPath := NormalDir(ExtractFilePath(TableName));
  CheckErrorTable := TabPath + 'VERIFY.DB';
  ErrorTable := TabPath + 'REBUILD.DB';
  ProblemTable := TabPath + 'PROBLEM.DB';
  KeyViolationTable := TabPath + 'KEYVIOL.DB';
  CheckBackupTable;
end;

{ Utility routines }

function GetPxTableNames(const DirectoryName: string; List: TStrings): string;
var
  hDB: HDBIDb;
  Cursor: HDBICur;
  DirName: string;
  Desc: FILEDesc;
  DbPath: DBIPATH;
begin
{$IFDEF WIN32}
  Session.Active := True;
{$ENDIF}
  DirName := DirectoryName;
  if not IsDirectory(DirName) then DirName := GetAliasPath(DirName);
  Result := DirName;
  Check(DbiOpenDatabase(nil, nil, dbiREADWRITE, dbiOPENSHARED,
    nil, 0, nil, nil, hDB));
  try
    Check(DbiSetDirectory(hDB, StrPLCopy(DbPath, DirName, SizeOf(DbPath) - 1)));
    List.BeginUpdate;
    try
      List.Clear;
      Check(DbiOpenFileList(hDB, '*.db', Cursor));
      try
        while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do begin
          if (DirName[Length(DirName)] <> '\') and (Length(DirName) > 1) then
            DirName := DirName + '\'
          else if Length(DirName) = 1 then DirName := DirName + ':\';
          List.Add(Format('%s%s', [DirName, StrPas(Desc.szFileName)]));
        end;
      finally
        DbiCloseCursor(Cursor);
      end;
    finally
      List.EndUpdate;
    end;
  finally
    DbiCloseDatabase(hDB);
  end;
end;

procedure CheckTable(const TableName: string; Repair: TCheckRepair);
var
  TU: TTUtility;
begin
  CheckTU;
  if not FileExists(ChangeFileExt(TableName, '.DB')) then
    DatabaseError(STUNoTables);
  TU := TTUtility.Create;
  try
    TU.CheckRepair := Repair;
    TU.ShowNoError := True;
    try
      TU.TableName := TableName;
      TU.DefaultBackupNames;
      TU.CheckTable;
      TU.DropErrorTable;
    except
      on E: ETUtilityError do
        begin
          if TUtilityLoaded then Application.HandleException(TU)
          else raise;
        end;
      else raise;
    end;
  finally
    TU.Free;
  end;
end;

procedure CheckTables(const TablesDir: string; Repair: TCheckRepair);
var
  List: TStrings;
  TU: TTUtility;
  I: Integer;
begin
  CheckTU;
  TU := TTUtility.Create;
  try
    List := TStringList.Create;
    try
      GetPxTableNames(TablesDir, List);
      if List.Count <= 0 then DatabaseError(STUNoTables);
      TU.CheckRepair := Repair;
      TU.ShowNoError := False;
      for I := 0 to List.Count - 1 do
        try
          TU.TableName := List[I];
          TU.DefaultBackupNames;
          TU.CheckTable;
        except
          on E: ETUtilityError do
            begin
              if TUtilityLoaded then Application.HandleException(TU)
              else raise;
            end;
          else raise;
        end;
      TU.DropErrorTable;
    finally
      List.Free;
    end;
  finally
    TU.Free;
  end;
end;

initialization
  LoadTUtility;
{$IFNDEF WIN32}
  AddExitProc(FreeTUtility);
{$ENDIF}
end.