Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/s_to_z/tblinfo/tblinfo.pas

Pascal/Delphi Source File | 1996-09-15 | 11.1 KB | 392 lines

{************************************************}
{ TBLINFO.PAS                                    }
{ Wrapper unit for TblInfo component             }
{ Compiled with Borland Delphi 1.0               }
{ ⌐1995, SJHDesign Inc.                          }
{************************************************}

unit TblInfo;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, TblDlg, DB, DBTables, dbiprocs, dbitypes,dbierrs;

type
  TTblInfoDlg = class(TComponent)

  private
    fColor : TColor;
    fFont: TFont;
    fCaption :string;
    fTable : TTable;
    tblsize,tbldate : string;
    nIndexes : integer;
    procedure DlgColor(value : TColor);
    procedure DlgFont(value : TFont);
    procedure DlgCaption(value : string);
    procedure DlgTable(value : TTable);
    function GetTableType(table : tTable) : string;
    procedure GetTableDate_Size(table : tTable);
    procedure BDE_Error(code:integer);
    procedure DisplayIndexes(table : tTable);
    procedure DisplayFields(table : tTable);

  protected
    { Protected declarations }

  public
    constructor Create(AOwner: TComponent); override;
    function Execute : Boolean;
    destructor Destroy; override;

  published
    property Color : TColor read FColor write DlgColor default clBtnFace;
    property Font : TFont read FFont write DlgFont;
    property Caption: String read FCaption write DlgCaption;
    property Table : TTable read FTable write DlgTable;
  end;
var
  MultPageDlg: TMultPageDlg;

function TranslateFieldType(fldtyp,subtyp :Integer) : string;
procedure Register;

implementation

constructor TTblInfoDlg.Create(AOwner: TComponent);
var val:boolean;
begin
  inherited Create(AOwner);
  fColor := ClBtnFace;
  fFont := TFont.Create;
  fCaption := 'Table Information';
  fTable := nil;
  nIndexes := 0;
end;


function TTblInfoDlg.Execute : Boolean;
begin
  MultPageDlg := TMultPageDlg.Create(Application);
  MultPageDlg.Color := fColor;
  MultPageDlg.TabSet.SelectedColor := fColor;
  MultPageDlg.Font := fFont;
  MultPageDlg.Caption := fCaption;
  if fTable.active = false then
  begin
    multpagedlg.free;
    messagebox(0, 'Table Not Found','Error',mb_ok);
    exit;
  end;
  MultPageDlg.Caption := ftable.tablename;
  MultPageDlg.NumFlds.Caption := inttostr(ftable.FieldCount);
  MultPageDlg.NumRecs.Caption := inttostr(ftable.RecordCount);
  MultPageDlg.TblType.Caption := GetTableType(ftable);
  nIndexes := ftable.IndexFieldCount;
  DisplayIndexes(ftable);
  MultPageDlg.NumIndex.Caption := inttostr(nIndexes);
  GetTableDate_Size(ftable);
  MultPageDlg.TblSize.Caption := tblsize;
  MultPageDlg.LastChng.Caption := tbldate;
  DisplayFields(ftable);
  try
    result := (multpagedlg.showModal = IDOK);
  finally
    multpagedlg.free;
  end;
end;


destructor TTblInfoDlg.Destroy;
begin
  fFont.free;
  inherited Destroy;
end;


procedure TTblInfoDlg.DlgColor(value : TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
  end;
end;

procedure TTblInfoDlg.DlgFont(value : TFont);
begin
  if FFont <> Value then
  begin
    FFont.Assign(Value);
  end;
end;


procedure TTblInfoDlg.DlgCaption(value : string);
begin
  FCaption := Value;
end;

procedure TTblInfoDlg.DlgTable(value : TTable);
begin
  ftable := Value;
end;

function TTblInfoDlg.GetTableType(table : tTable):string;
begin
  if Table.tableType = ttDefault then
  begin
    if CompareText(ExtractFileExt(Table.TableName), '.dbf') = 0 then
    begin
      GetTableType := 'DBase';
      exit;
    end
    else if CompareText(ExtractFileExt(Table.TableName), '.db') = 0 then
    begin
      GetTableType := 'Paradox';
      exit;
    end
    else GetTableType := 'ODBC or other';
  end
  else if table.tableType = ttDBase then GetTableType := 'DBase'
  else if Table.TableType = ttParadox then GetTableType := 'Paradox'
  else GetTableType := 'ODBC or other';
end;

procedure TTblInfoDlg.GetTableDate_Size(table : tTable);
var
  hCur : hDBICur;
  name : array[0..80]of Char;
  recbuf :pbyte;
  tblprops :curprops;
  szTemp : array[0..255] of CHAR;
  szTempLong: LongInt absolute szTemp;
  dtTemp : longint;
  bIsBlank: bool;

begin
  strPcopy(name,Table.TableName);
  if dbiOpenTableList(Table.DBHandle,false,false,name, hcur) = DBIERR_NONE then
  begin
    if dbigetcursorprops(hCur,tblprops)= DBIERR_NONE then
    begin
      {$I+}
      try
        GetMem(RecBuf, tblProps.iRecBufSize*sizeof(BYTE));
      except
        on EOutOfMemory do
        begin
         DbiCloseCursor(hCur);
         BDE_Error(4);
         exit;
        end;
      {$I-}
      end;
      dbisettobegin(hCur);
      if DbiGetNextRecord(hCur, dbiNOLOCK, RecBuf, nil) = DBIERR_NONE then
      begin
        if DbiGetField(hCur, 7, RecBuf, (@szTemp), bisblank) = DBIERR_NONE then
        begin
          if DbiGetField(hCur, 5, RecBuf, (@dtTemp), bIsBlank) <> DBIERR_NONE then BDE_Error(1)
          else
          begin
            tbldate := DateToStr(dtTemp);
            Str(szTempLong,tblsize);
          end;
          if recbuf <> nil then freemem(recbuf, tblprops.iRecBufSize * sizeof(BYTE));
          DbiCloseCursor(hCur);
        end
        else
        begin
          if recbuf <> nil then freemem(recbuf, tblprops.iRecBufSize * sizeof(BYTE));
          DbiCloseCursor(hCur);
          BDE_Error(1);
        end;
      end
      else
      begin
        if recbuf <> nil then freemem(recbuf, tblprops.iRecBufSize * sizeof(BYTE));
        DbiCloseCursor(hCur);
        BDE_Error(1);
      end;
    end
    else
    begin
      DbiCloseCursor(hCur);
      BDE_Error(1);
    end;
  end
  else BDE_Error(1);
end;


procedure TTblInfoDlg.DisplayIndexes(table:TTable);
var
  hCur: hdbicur;
  name : array[0..80]of Char;
  recbuf :pbyte;
  tblprops :curprops;
  nmTemp : array[0..255] of CHAR;
  BoolTemp, bIsBlank: bool;
  i: integer;
begin
  i := 0;
  bisblank := false;
  strPcopy(name,Table.TableName);
  if DbiOpenIndexList(Table.DBHandle,name, nil,hCur) = DBIERR_NONE then
  begin
    if dbigetcursorprops(hCur,tblprops)= DBIERR_NONE then
    begin
      dbisettobegin(hCur);
{This requires some explanation-the TTable.IndexFieldCount property is used to
 get an idea of how many indexed fields we have(nIndexes), but it does not count
 Paradox .PX or Dbase .MDX maintained indexes. DbiOpenIndexList WILL show these
 index types as an incomplete record and return an error value, so if we want them to
 show up in our index listing, we must read the record, ignore the DBIERR_EOF from
 DbiGetNextRecord and run through the loop once more. This is the reason we loop
 nIndexes times instead of nIndexes-1 times. The number of strings in the resulting
 index list is used as the Index Fields number on the first page of the dialog to make
 it agree with the number of Indexes listed on page 3. It's a kludge, but it works...}
      for i := 0 to nIndexes do
      begin
        {$I+}
        try
          GetMem(RecBuf, tblProps.iRecBufSize*sizeof(BYTE));
        except
          on EOutOfMemory do
          begin
            DbiCloseCursor(hCur);
            BDE_Error(4);
            exit;
          end;
        {$I-}
        end;
        if DbiGetNextRecord(hCur, dbiNOLOCK, RecBuf, nil) = DBIERR_NONE then
        begin
          DbiGetField(hCur, 1, RecBuf, (@nmTemp), bisblank);
          MultPageDlg.Outline4.add(i,StrPas(nmtemp));
          DbiGetField(hCur, 5, RecBuf, (@BoolTemp), bisblank);
          if BoolTemp then MultPageDlg.Outline5.add(i,'Yes')
          else MultPageDlg.Outline5.add(i,'No');
          DbiGetField(hCur, 6, RecBuf, (@BoolTemp),bisblank);
          if BoolTemp then MultPageDlg.Outline6.add(i,'Yes')
          else MultPageDlg.Outline6.add(i,'No');
          if recbuf <> nil then freemem(recbuf, tblprops.iRecBufSize * sizeof(BYTE));
        end
        else if recbuf <> nil then freemem(recbuf, tblprops.iRecBufSize * sizeof(BYTE));
      end;
    end
    else
    begin
      DbiCloseCursor(hCur);
      BDE_Error(3);
    end;
    DbiCloseCursor(hCur);
    nindexes := MultPageDlg.Outline4.ItemCount;
  end
  else BDE_Error(3);
end;


procedure TTblInfoDlg.DisplayFields(table:TTable);
var
  hCur : hDBICur;
  name : array[0..80]of Char;
  recbuf :pbyte;
  tblprops :curprops;
  nmTemp : array[0..255] of CHAR;
  typTemp,lntemp,subtyptemp : Integer;
  bIsBlank: bool;
  i,recs: integer;
  lnTempStr : string;
begin
  i := 0;
  recs := table.FieldCount-1;
  strPcopy(name,Table.TableName);
  if DbiOpenFieldList(table.DBHandle, name, nil, False, hCur) = DBIERR_NONE then
  begin
    if dbiGetCursorProps(hCur,tblprops)= DBIERR_NONE then
    begin
      dbiSetToBegin(hCur);
      for i := 0 to recs do
      begin
      {$I+}
      try
        GetMem(RecBuf, tblProps.iRecBufSize*sizeof(BYTE));
      except
        on EOutOfMemory do
        begin
          DbiCloseCursor(hCur);
          BDE_Error(4);
          exit;
        end;
      end;
      {$I-}
      DbiGetNextRecord(hCur, dbiNOLOCK, RecBuf, nil);
      DbiGetField(hCur, 2, RecBuf, (@nmTemp), bisblank);
      DbiGetField(hCur, 5, RecBuf, (@lnTemp), bisblank);
      DbiGetField(hCur, 3, RecBuf, (@typTemp),bisblank);
      if typTemp = 7 then DbiGetField(hCur, 4, RecBuf, (@subtypTemp),bisblank)
      else if typTemp = 3 then DbiGetField(hCur, 4, RecBuf, (@subtypTemp),bisblank)
      else subtypTemp := 0;
      MultPageDlg.Outline1.add(i,StrPas(nmtemp));
      Str(lnTemp,lnTempStr);
      MultPageDlg.Outline2.add(i,lnTempStr);
      MultPageDlg.Outline3.add(i,TranslateFieldType(typTemp, subtypTemp));
      if recbuf <> nil then freemem(recbuf, tblprops.iRecBufSize * sizeof(BYTE));
      end;
      DbiCloseCursor(hCur);
    end
    else
    begin
      DbiCloseCursor(hCur);
      BDE_Error(2);
    end;
  end
  else BDE_Error(2);
end;

function TranslateFieldType(fldtyp,subtyp:integer) : string;
const
   TypIndex : array [0..16] of string [10] =
          ('Unknown', 'String', 'Date', 'Blob', 'Boolean', 'ShortInt',
           'LongInt', 'Float', 'Decimal', 'Bytes', 'Time', 'DateTime',
           'UShortInt', 'ULongInt', 'Float80', 'VarBytes', 'LockInfo');
   SubTypIndex: array [21..28] of string [10] =
             ('Currency', 'Memo', 'Binary', 'Fmt.Memo', 'OLE',
              'Graphic', 'dBase OLE', 'User Typed');

begin
  if subtyp > 0 then TranslateFieldType := SubTypIndex[subtyp]
  else TranslateFieldType := TypIndex[fldtyp];
end;


procedure TTblInfoDlg.BDE_Error(code:integer);
var
  str1 : string;
  NTstr1 : array[0..28] of char;
begin
  case code of
    1:
    begin
      StrPCopy(NTStr1,'Table Info Incomplete');
      tbldate := 'Unknown';
      tblsize := 'Unknown';
    end;
    2: StrPCopy(NTStr1,'Unable to Open Field List');
    3: StrPCopy(NTStr1,'Unable to Open Index List');
    4: StrPCopy(NTStr1,'Not Enough Memory');
  else exit;
  end;
  messagebox(0,NTStr1,'Database Error',mb_ok or mb_iconstop);
end;

procedure Register;
begin
  RegisterComponents('Data Controls', [TTblInfoDlg]);
end;

end.