Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/QDB/QDBV.ZIP/QDBView.pas

Pascal/Delphi Source File | 1998-07-29 | 53.3 KB | 2,061 lines

{*****************************************************************************}
{                                                                             }
{          QDBView v2.11 Visual Components for Delphi 1, 2, & 3               }
{                                                                             }
{       Copyright (c) 1995, 1996, 1997, 1998 Robert R. Marsh, S.J.            }
{             & the British Province of the Society of Jesus                  }
{                                                                             }
{              This source code may *not* be redistributed                    }
{              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~                    }
{                                                                             }
{       If you like QDBView and find yourself using it please consider            }
{       making a donation to your favorite charity. I would also be           }
{       pleased if you would acknowledge QDB in any projects that             }
{       make use of it.                                                       }
{                                                                             }
{       QDBView is supplied as is. The author disclaims all warranties,           }
{       expressed or implied, including, without limitation, the              }
{       warranties of merchantability and of fitness for any purpose.         }
{       The author assumes no liability for damages, direct or                }
{       consequential, which may result from the use of QDBView.                  }
{                                                                             }
{                           [e-mail]                                   }
{                  http://home.sprynet.com/sprynet/rrm                        }
{                                                                             }
{*****************************************************************************}


{$F+}

unit QDBView;

interface

uses
{$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs, {$ENDIF}
  Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, QDB;

{ The field type describes the format in which a field is }
{ stored in the QDB file. QDBItem's AsXXX properties need }
{ to know how data is stored so they can interpret it.    }
{                                                         }
{  ftunknown: not for use                                 }
{  ftinteger: a single longint                            }
{  ftintegers: several longints                           }
{  ftreal: a floating point value of type extended        }
{  ftboolean: a boolean value                             }
{  ftdatetime: a Delphi TDateTime value                   }
{  ftdate: TDateTime but just the date                    }
{  fttime: TDateTime but just the time                    }
{  ftstring: a string value (as pchar)                    }
{  ftstrings: string list contents                        }
{  ftrichstrings: richedit contents with formatting       }
{  ftgraphic: a graphic                                   }
{  ftthing: a generic lump of data, say from a stream     }
type
  TQDBFieldType = (ftunknown, ftinteger, ftintegers, ftreal,
    ftboolean, ftdatetime, ftstring, ftstrings,
    ftrichstrings, ftgraphic, ftthing, ftdate, fttime);

type
  TKey = QDB.TKey;
  TKeyEvent = procedure(Sender: TObject; var Key: TKey) of object;

type
  EQDBItemError = class(EQDBError);
  EQDBConvertError = class(EQDBItemError);
  EQDBFieldError = class(EQDBItemError);
  EQDBKeyError = class(EQDBItemError);
  EQDBViewError = class(EQDBError);

  { QDBItem descends from TQDB and handles the parsing of an }
  { item into fields. The field structure is defined by the  }
  { AddField method or by loading the structure from a file  }
  { using FetchStructure.                                    }
  { Clear, Fetch, and Store handle items and individual      }
  { fields can be accessed via the AsXXX[index] properties.  }
  { The format strings govern the conversion of date/time &  }
  { real values. An OnKey event handler must be assigned if  }
  { items are to be stored.                                  }
type
  TQDBItem = class(TQDB)
  private
    CurrentItem: TMemoryStream;
    Fields: TStringList;
    FDateTimeFormatStr: string;
    FRealFormatStr: string;
    FOnKey: TKeyEvent;
  protected
    procedure DoCancel; override;
    procedure DoDelete; override;
    procedure DoEdit; override;
    procedure DoInsert; override;
    procedure DoPost; override;
    function GetAsBoolean(Index: integer): boolean;
    function GetAsDate(Index: integer): TDateTime;
    function GetAsDateTime(Index: integer): TDateTime;
    function GetAsInteger(Index: integer): longint;
    function GetAsReal(Index: integer): extended;
    function GetAsString(Index: integer): string;
    function GetAsTime(Index: integer): TDateTime;
    function GetBoolean(Index: integer): boolean;
    function GetCount: integer;
    function GetDate(Index: integer): TDateTime;
    function GetDateTime(Index: integer): TDateTime;
    function GetInteger(Index: integer): longint;
    function GetName(Index: integer): string;
    function GetReal(Index: integer): extended;
    function GetString(Index: integer): string;
    function GetStrings(Index: integer): string;
    function GetTime(Index: integer): TDateTime;
    function GetType(Index: integer): TQDBFieldType;
    procedure SetAsBoolean(Index: integer; Value: boolean);
    procedure SetAsDate(Index: integer; const Value: TDateTime);
    procedure SetAsDateTime(Index: integer; Value: TDateTime);
    procedure SetAsInteger(Index: integer; Value: longint);
    procedure SetAsReal(Index: integer; Value: extended);
    procedure SetAsString(Index: integer; const Value: string);
    procedure SetAsTime(Index: integer; Value: TDateTime);
    procedure SetBoolean(Index: integer; Value: boolean);
    procedure SetDate(Index: integer; Value: TDateTime);
    procedure SetDateTime(Index: integer; Value: TDateTime);
    procedure SetField(Index: integer; Stream: TMemoryStream);
    procedure SetInteger(Index: integer; Value: longint);
    procedure SetReal(Index: integer; Value: extended);
    procedure SetString(Index: integer; const Value: string);
    procedure SetTime(Index: integer; Value: TDateTime);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddField(FieldName: string; FieldType: TQDBFieldType);
    procedure Clear; virtual;
    procedure ClearStructure;
    procedure Fetch; virtual;
    procedure ListFileFieldNames(Names: TStrings);
    procedure FetchStructure;
    function FieldIndex(const Name: string): integer;
    procedure FirstItem; override;
    function GetField(Index: integer): TMemoryStream;
    procedure LastItem; override;
    procedure NextItem; override;
    procedure PrevItem; override;
    procedure Refresh; override;
    procedure Store; virtual;
    procedure StoreAs(NewKey: TKey);
    procedure StoreStructure;
    property FieldCount: integer read GetCount;
    property FieldNames[Index: integer]: string read GetName;
    property FieldTypes[Index: integer]: TQDBFieldType read GetType;
    property AsInteger[Index: integer]: longint read GetAsInteger write SetAsInteger;
    property AsReal[Index: integer]: extended read GetAsReal write SetAsReal;
    property AsBoolean[Index: integer]: boolean read GetAsBoolean write SetAsBoolean;
    property AsString[Index: integer]: string read GetAsString write SetAsString;
    property AsDate[Index: integer]: TDateTime read GetAsDate write SetAsDate;
    property AsDateTime[Index: integer]: TDateTime read GetAsDateTime write SetAsDateTime;
    property AsTime[Index: integer]: TDateTime read GetAsTime write SetAsTime;
    property Editing;
    property Inserting;
  published
    property AutoEdit;
    property OnKey: TKeyEvent read FOnKey write FOnKey;
    property DateTimeFormatStr: string read FDateTimeFormatStr write FDateTimeFormatStr;
    property RealFormatStr: string read FRealFormatStr write FRealFormatStr;
  end;

type
  TClassProc = procedure(AControl: TControl; Stream: TStream);

type
  TRegistrationInfo = record
    AClass: TControlClass;
    AType: TQDBFieldType;
    ClearProc: TClassProc;
    FetchProc: TClassProc;
    StoreProc: TClassProc;
  end;

type
  TRegisteredControlList = class(TList)
  public
    constructor Create;
    destructor Destroy; override;
    function GetRegistrationInfo(Instance: TControl; var RegistrationInfo: TRegistrationInfo): boolean;
    procedure RegisterControl(AClass: TControlClass; FieldType: TQDBFieldType; ClearProc, FetchProc, StoreProc: TClassProc);
  end;

  { QDBView descends from TQDB via TQBItem and adds the ability  }
  { to automate storage of data in controls on an associated     }
  { panel. The most frequently used controls are registered by   }
  { default but others can be added or existing behavior changed }
  { if desired. The way the panel displays items is governed by  }
  { the AutoEdit, ActiveColor, InactiveColor, and InactiveStyle  }
  { properties.                                                  }
type
  TQDBView = class(TQDBItem)
  private
    RegisteredControls: TRegisteredControlList;
    ControlList: TList;
    FActiveColor: TColor;
    FInactiveColor: TColor;
    FActive: boolean;
    FExcludeTag: longint;
    FPanel: TCustomPanel;
  protected
    procedure BuildFieldList;
    procedure DoCancel; override;
    procedure DoDelete; override;
    procedure DoEdit; override;
    procedure DoInsert; override;
    procedure DoPost; override;
    function FileIsStructured: boolean;
    function FileMatchesPanel: boolean;
    procedure FocusFirstTab;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetActiveColor(Value: TColor);
    procedure SetActive(Value: boolean);
    procedure SetFileName(Value: TQDBFileName); override;
    procedure SetInactiveColor(Value: TColor);
    procedure SetPanel(Value: TCustomPanel);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CheckStructure: boolean;
    procedure Clear; override;
    procedure ClearStructure;
    procedure Fetch; override;
    procedure FirstItem; override;
    procedure LastItem; override;
    procedure NextItem; override;
    procedure PrevItem; override;
    procedure RegisterControl(AClass: TControlClass; FieldType: TQDBFieldType; ClearProc, FetchProc, StoreProc: TClassProc);
    procedure RegisterGraphicFormat(const AExtension: string; AGraphicClass: TGraphicClass);
    procedure Refresh; override;
    procedure Store; override;
    procedure StoreStructure;
  published
    property ActiveColor: TColor read FActiveColor write SetActiveColor;
    property ExcludeTag: longint read FExcludeTag write FExcludeTag;
    property InactiveColor: TColor read FInactiveColor write SetInactiveColor;
    property Panel: TCustomPanel read FPanel write SetPanel;
  end;

function GetGraphicClass(ext: string): TGraphicClass;

implementation

uses
  Clipbrd
{$IFDEF WIN32}
  , ComCtrls
{$ENDIF};

const
  SUnknownGraphic = 'unknown graphic class';
  SFieldCorrupt = 'problem with fields';
  SBadValue = '%s is not a valid value';
  SInvalidFieldType = 'invalid field type';
  SNoOnKey = 'Cannot store data unless an OnKey handler is assigned';
  SBadMatch = 'File doesn''t match panel';
  SNotStreamable = 'not streamable';
  SBadFieldIndex = 'index doesn''t correspond to a field';

  { Default control handlers registered in TQDBView.Create }

  { To add your own you must pay attention to their structure. }
  { Clear handlers simply have to put AControl into whatever   }
  { passes as an empty state.                                  }
  { Fetch handlers have to take the data in Stream and put it  }
  { into AControl in an appropriate way. An empty Stream or an }
  { error fetching the data should call the Clear handler.     }
  { Store handlers just put AControl's data into Stream.       )
  { In general the data should be stored as one of the formats }
  { defined by TQDBFieldType.                                     }

  { ftstring }

procedure ClearCustomEdit(AControl: TControl; Stream: TStream);
begin
  (AControl as TCustomEdit).Text := '';
end;

procedure FetchCustomEdit(AControl: TControl; Stream: TStream);
var
  con: TCustomEdit;
  p: pchar;
  Len: longint;
begin
  try
    Len := Stream.size;
    if Len = 0 then
      Abort;
    con := (AControl as TCustomEdit);
    p := StrAlloc(Len);
    try
      Stream.ReadBuffer(p^, Len);
      con.SetTextBuf(p);
    finally
      StrDispose(p);
    end;
  except
    ClearCustomEdit(AControl, Stream);
  end;
end;

procedure StoreCustomEdit(AControl: TControl; Stream: TStream);
var
  con: TCustomEdit;
  Len: longint;
  p: pchar;
begin
  con := (AControl as TCustomEdit);
  Len := con.GetTextLen + 1;
  p := StrAlloc(Len);
  try
    con.GetTextBuf(p, Len);
    Stream.Write(p^, Len);
  finally
    StrDispose(p);
  end;
end;

{$IFDEF WIN32}
{ ftrichstrings }

procedure ClearRichEdit(AControl: TControl; Stream: TStream);
begin
  (AControl as TRichEdit).Clear;
end;

procedure FetchRichEdit(AControl: TControl; Stream: TStream);
begin
  try
    (AControl as TRichEdit).Lines.LoadFromStream(Stream);
  except
    ClearRichEdit(AControl, Stream);
  end;
end;

procedure StoreRichEdit(AControl: TControl; Stream: TStream);
begin
  (AControl as TRichEdit).Lines.SaveToStream(Stream);
end;
{$ENDIF}

{ ftinteger }

procedure ClearCustomRadioGroup(AControl: TControl; Stream: TStream);
begin
  TRadioGroup(AControl).ItemIndex := -1;
end;

procedure FetchCustomRadioGroup(AControl: TControl; Stream: TStream);
var
  n: longint;
begin
  try
    Stream.ReadBuffer(n, SizeOf(n));
    TRadioGroup(AControl).ItemIndex := n;
  except
    ClearCustomRadioGroup(AControl, Stream)
  end;
end;

procedure StoreCustomRadioGroup(AControl: TControl; Stream: TStream);
var
  n: longint;
begin
  n := TRadioGroup(AControl).ItemIndex;
  Stream.WriteBuffer(n, SizeOf(n));
end;

{ ftinteger }

procedure ClearCustomCheckBox(AControl: TControl; Stream: TStream);
begin
  TCheckBox(AControl).Checked := false;
end;

procedure FetchCustomCheckBox(AControl: TControl; Stream: TStream);
var
  n: longint;
begin
  try
    Stream.ReadBuffer(n, SizeOf(n));
    TCheckBox(AControl).State := TCheckBoxState(n);
  except
    ClearCustomCheckBox(AControl, Stream)
  end;
end;

procedure StoreCustomCheckBox(AControl: TControl; Stream: TStream);
var
  n: longint;
begin
  n := longint(TCheckBox(AControl).State);
  Stream.WriteBuffer(n, SizeOf(n));
end;

{ ftstring }

procedure ClearCustomComboBox(AControl: TControl; Stream: TStream);
begin
  (AControl as TCustomComboBox).SetTextBuf(nil);
end;

procedure FetchCustomComboBox(AControl: TControl; Stream: TStream);
var
  p: pchar;
begin
  try
    if Stream.size = 0 then
      Abort;
    p := StrAlloc(Stream.size);
    try
      Stream.ReadBuffer(p^, Stream.size);
      (Acontrol as TCustomComboBox).SetTextBuf(p);
    finally
      StrDispose(p);
    end;
  except
    ClearCustomComboBox(AControl, Stream)
  end;
end;

procedure StoreCustomComboBox(AControl: TControl; Stream: TStream);
var
  con: TCustomComboBox;
  Len: longint;
  p: pchar;
begin
  con := (AControl as TCustomComboBox);
  Len := con.GetTextLen + 1;
  p := StrAlloc(Len);
  try
    con.GetTextBuf(p, Len);
    Stream.Write(p^, Len);
  finally
    StrDispose(p);
  end;
end;

type
  THackListBox = class(TCustomListBox);

  { ftintegers }

procedure ClearCustomListBox(AControl: TControl; Stream: TStream);
var
  con: TCustomListBox;
  n: longint;
  ms: boolean;
begin
  con := (AControl as TCustomListBox);
  ms := THackListBox(con).MultiSelect;
  THackListBox(con).MultiSelect := true;
  for n := 1 to con.Items.Count do
  begin
    con.Selected[n - 1] := false;
  end;
  THackListBox(con).MultiSElect := ms;
  con.ItemIndex := -1;
end;

procedure FetchCustomListBox(AControl: TControl; Stream: TStream);
var
  con: TCustomListBox;
  n: longint;
  ms: boolean;
begin
  ClearCustomListBox(AControl, Stream);
  try
    con := (AControl as TCustomListBox);
    ms := THackListBox(con).MultiSelect;
    THackListBox(con).MultiSelect := true;
    while true do
    begin
      Stream.ReadBuffer(n, SizeOf(longint));
      if (n < 0) or (n > con.Items.Count) then
        Break;
      con.Selected[n] := true;
    end;
    if con.SelCount <= 1 then
      THackListBox(con).MultiSelect := ms;
  except
    ClearCustomListBox(AControl, Stream);
  end;
end;

procedure StoreCustomListBox(AControl: TControl; Stream: TStream);
var
  con: TCustomListBox;
  n: longint;
  i: longint;
begin
  con := (AControl as TCustomListBox);
  for n := 1 to con.Items.Count do
    if con.Selected[n - 1] then
    begin
      i := n - 1;
      Stream.Write(i, SizeOf(longint));
    end;
  i := -1;
  Stream.Write(i, SizeOf(longint));
end;

type
  PFileFormat = ^TFileFormat;
  TFileFormat = record
    GraphicClass: TGraphicClass;
    Extension: string;
    Next: PFileFormat;
  end;

const
  WMFMetafileFormat: TFileFormat = (
    GraphicClass: TMetafile;
    Extension: 'wmf';
    Next: nil);
  MetaFileFormat: TFileFormat = (
    GraphicClass: TMetafile;
    Extension: 'emf';
    Next: @WMFMetaFileFormat);
  IconFormat: TFileFormat = (
    GraphicClass: TIcon;
    Extension: 'ico';
    Next: @MetafileFormat);
  BitmapFormat: TFileFormat = (
    GraphicClass: TBitmap;
    Extension: 'bmp';
    Next: @IconFormat);

const
  FileFormatList: PFileFormat = @BitmapFormat;

  { ftgraphic }

procedure ClearImage(AControl: TControl; Stream: TStream);
begin
  (AControl as TImage).Picture.Assign(nil);
end;

function GetGraphicClass(ext: string): TGraphicClass;
var
  Graphic: PFileFormat;
begin
  Result:=nil;
  Graphic := FileFormatList;
  while Graphic <> nil do
  begin
    with Graphic^ do
    begin
      if Extension <> Ext then
        Graphic := Next
      else
      begin
        Result:=GraphicClass;
        Exit;
      end;
    end;
  end;
end;

procedure FetchImage(AControl: TControl; Stream: TStream);
var
  con: TImage;
  Ext: array[0..3] of char;
  GraphicClass: TGraphicClass;
  NewGraphic: TGraphic;
begin
  try
    con := (AControl as TImage);
    Ext[3] := #0;
    Stream.ReadBuffer(Ext[0], 3);
    GraphicClass:=GetGraphicClass(StrPas(Ext));
    if GraphicClass <> nil then
    begin
          NewGraphic := GraphicClass.Create;
          try
            try
              NewGraphic.LoadFromStream(Stream);
            except
              NewGraphic.Free;
              raise;
            end;
            con.Picture.Graphic:=NewGraphic;
            exit;
          finally
            NewGraphic.Free;
          end;
        end;
  except
    ClearImage(AControl, Stream);
  end;
end;

procedure StoreImage(AControl: TControl; Stream: TStream);
var
  con: TImage;
  Ext: array[0..3] of char;
begin
  con := (AControl as TImage);
  StrPCopy(Ext, LowerCase(GraphicExtension(TGraphicClass(con.Picture.Graphic.ClassType))));
  if StrPas(Ext) <> '' then
  begin
    Stream.WriteBuffer(Ext[0], 3);
    con.Picture.Graphic.SaveToStream(Stream);
  end
  else
    raise Exception.Create(SUnknownGraphic);
end;

{ TQDBItem }

const
  StructureIndicator = 'QF.';

const
  {DateInDelphi2/3 := DateInDelphi1 - DateFiddle}
  {All dates are stored in Delphi 2/3 format    }
  DateFiddle: TDateTime = 693594.0;

type
  TFieldInfo = class
    TheData: TMemoryStream;
    TheType: TQDBFieldType;
  end;

constructor TQDBItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  CurrentItem := TMemoryStream.Create;
  Fields := TStringList.Create;
  Fields.Sorted := false;
  RealFormatStr := '';
  DateTimeFormatStr := 'c';
end;

destructor TQDBItem.Destroy;
var
  n: integer;
  i: integer;
begin
  CurrentItem.Free;
  n := Fields.Count;
  for i := n downto 1 do
  begin
    TFieldInfo(Fields.Objects[i - 1]).TheData.Free;
    TFieldInfo(Fields.Objects[i - 1]).Free;
    Fields.Delete(i - 1);
  end;
  Fields.Free;
  inherited Destroy;
end;

{ Add a new field definition }

procedure TQDBItem.AddField(FieldName: string; FieldType: TQDBFieldType);
var
  i: TFieldInfo;
begin
  i := TFieldInfo.Create;
  i.TheData := TMemoryStream.Create;
  i.TheType := FieldType;
  Fields.AddObject(FieldName, i);
end;

{ Call TQDB.DoCancel and reload the item }

procedure TQDBItem.DoCancel;
begin
  inherited DoCancel;
  if Ready then
  begin
    Fetch;
  end;
end;

{ Clear each field }

procedure TQDBItem.Clear;
var
  n: integer;
  ThisField: TFieldInfo;
begin
  for n := 1 to Fields.Count do
  begin
    ThisField := TFieldInfo(Fields.Objects[n - 1]);
    ThisField.TheData.Clear;
  end;
end;

{ Remove all record of field structure from the file }

procedure TQDBItem.ClearStructure;
begin
  AdminClear(StructureIndicator);
end;

{ Call TQDB.DoDelete and either load the next item or clear it }

procedure TQDBItem.DoDelete;
begin
  if Ready then
  begin
    inherited DoDelete;
    if Count > 0 then
      Fetch
    else
      Clear;
  end;
end;

{ Call TQDB.DoEdit, i.e., enter edit mode }

procedure TQDBItem.DoEdit;
begin
  inherited DoEdit;
end;

{ Load the current item and parse it into fields }

procedure TQDBItem.Fetch;
var
  n: integer;
  ThisField: TFieldInfo;
  Len: longint;
begin
  if Count > 0 then
  begin
    CurrentItem.Clear;
    Get(CurrentItem);
    for n := 1 to Fields.Count do
    begin
      ThisField := TFieldInfo(Fields.Objects[n - 1]);
      ThisField.TheData.Clear;
      CurrentItem.ReadBuffer(Len, SizeOf(Len));
      if Len > 0 then
        ThisField.TheData.CopyFrom(CurrentItem, Len);
    end;
    CurrentItem.Clear;
  end;
end;

{ Fill a list with the field names as found in the file }

procedure TQDBItem.ListFileFieldNames(Names: TStrings);
var
  n: integer;
  T: TStringList;
  TheInfo: string;
  TheName: string;
  p: integer;
begin
  T := TStringList.Create;
  try
    AdminKeys(T, StructureIndicator);
    for n := 1 to T.Count do
    begin
      TheInfo := AdminAsString[T[n - 1]];
      TheName := TheInfo;
      p := Pos('.', TheName);
      if p = 2 then
        System.Delete(TheName, 1, 2)
      else
        raise EQDBFieldError.Create(SFieldCorrupt);
      p := Pos('.', TheName);
      if p >= 1 then
        System.Delete(TheName, p, Length(TheName));
      Names.Add(TheName);
    end;
  finally
    T.Free;
  end;
end;

{ Load the field structure from the file }

procedure TQDBItem.FetchStructure;
var
  n: integer;
  T: TStringList;
  TheInfo: string;
  TheName: string;
  TheType: TQDBFieldType;
  p: integer;
begin
  T := TStringList.Create;
  try
    Fields.Clear;
    AdminKeys(T, StructureIndicator);
    for n := 1 to T.Count do
    begin
      TheInfo := AdminAsString[T[n - 1]];
      TheType := TQDBFieldType(ord(TheInfo[1]));
      TheName := TheInfo;
      p := Pos('.', TheName);
      if p = 2 then
        System.Delete(TheName, 1, 2)
      else
        raise EQDBFieldError.Create(SFieldCorrupt);
      p := Pos('.', TheName);
      if p >= 1 then
        System.Delete(TheName, p, Length(TheName));
      AddField(TheName, TheType);
    end;
  finally
    T.Free;
  end;
end;

{ Get the place in the field list from a field name }

function TQDBItem.FieldIndex(const Name: string): integer;
{ -1 indicates the field name doesn't exist }
begin
  Result := Fields.IndexOf(Name);
end;

{ Call TQDB.FirstItem and load the item }

procedure TQDBItem.FirstItem;
begin
  if Ready then
  begin
    inherited FirstItem;
    Fetch;
  end;
end;

{ The following routines convert a field's data from one }
{ format to another.                                     }

function StrToBoolean(S: string): boolean;
begin
  try
    if s = '' then
      Result := false
    else
      Result := (S[1] in ['Y', 'y', 'T', 't']);
  except
    raise EQDBConvertError.Create(SBadValue);
  end;
end;

function TQDBItem.GetAsBoolean(Index: integer): boolean;
begin
  try
    case GetType(Index) of
      ftinteger: Result := (GetInteger(Index) > 0);
      ftboolean: Result := GetBoolean(Index);
      ftstring: Result := StrToBoolean(GetString(Index));
    else
      raise EQDBFieldError.Create(SInvalidFieldType);
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

function TQDBItem.GetAsDate(Index: integer): TDateTime;
begin
  try
    case GetType(Index) of
      ftreal: Result := GetReal(Index);
      ftstring: Result := StrToDateTime(GetString(Index));
      ftdatetime: Result := int(GetDateTime(Index));
      ftdate: Result:=  GetDate(Index);
    else
      raise EQDBFieldError.Create(SInvalidFieldType);
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

function TQDBItem.GetAsDateTime(Index: integer): TDateTime;
begin
  try
    case GetType(Index) of
      ftreal: Result := GetReal(Index);
      ftstring: Result := StrToDateTime(GetString(Index));
      ftdate: Result:= GetDate(Index);
      ftdatetime: Result := GetDateTime(Index);
      fttime: Result:=GetTime(Index);
    else
      raise EQDBFieldError.Create(SInvalidFieldType);
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

function TQDBItem.GetAsInteger(Index: integer): longint;
begin
  try
    case GetType(Index) of
      ftinteger: Result := GetInteger(Index);
      ftreal: Result := Round(GetReal(Index));
      ftdate: Result := Round(GetDate(Index));
      ftdatetime: Result := Round(GetDateTime(Index));
      ftboolean:
        if GetBoolean(Index) then
          Result := 1
        else
          Result := 0;
      ftstring: Result := StrToInt(GetString(Index));
    else
      raise EQDBFieldError.Create(SInvalidFieldType);
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

function TQDBItem.GetAsReal(Index: integer): extended;
begin
  try
    case GetType(Index) of
      ftinteger: Result := GetInteger(Index);
      ftreal: Result := GetReal(Index);
      ftstring: Result := StrToFloat(GetString(Index));
      ftdatetime: Result := GetDateTime(Index);
      ftdate: Result := GetDate(Index);
      fttime: Result := GetTime(Index);
    else
      raise EQDBFieldError.Create(SInvalidFieldType);
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

function TQDBItem.GetAsString(Index: integer): string;
begin
  try
    Result := '';
    case GetType(Index) of
      ftinteger: Result := IntToStr(GetInteger(Index));
      ftreal: Result := FormatFloat(RealFormatStr, GetReal(Index));
      ftboolean:
        if GetBoolean(Index) then
          Result := 'TRUE'
        else
          Result := 'FALSE';
      ftstring: Result := GetString(Index);
      ftstrings: Result := GetStrings(Index);
      ftdatetime: Result := FormatDateTime(DateTimeFormatStr, GetDateTime(Index));
      ftdate: Result := FormatDateTime(DateTimeFormatStr, GetDate(Index));
      fttime: Result := FormatDateTime(DateTimeFormatStr, GetTime(Index));
    else
      Result := 'N/A';
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

function TQDBItem.GetAsTime(Index: integer): TDateTime;
begin
  try
    case GetType(Index) of
      ftreal: Result := GetReal(Index);
      ftstring: Result := StrToDateTime(GetString(Index));
      ftdatetime: Result := frac(GetDateTime(Index));
      fttime: Result:=  GetTime(Index);
    else
      raise EQDBFieldError.Create(SInvalidFieldType);
    end;
  except
    on EConvertError do
      raise EQDBConvertError.CreateFmt(SBadValue, [GetString(Index)]);
  else
    raise
  end;
end;

{ The following routines convert a field's data to its native type }

function TQDBItem.GetBoolean(Index: integer): boolean;
var
  m: TMemoryStream;
begin
  Result := false;
  if GetType(Index) <> ftboolean then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size = SizeOf(Result) then
    m.ReadBuffer(Result, m.size);
  m.Position := 0;
end;

function TQDBItem.GetCount: integer;
begin
  Result := Fields.Count;
end;

function TQDBItem.GetDate(Index: integer): TDateTime;
var
  m: TMemoryStream;
begin
  Result := 0;
{$IFNDEF WIN32}
  Result := Result + DateFiddle;
{$ENDIF}
  if GetType(Index) <> ftdate then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size = SizeOf(Result) then
  begin
    m.ReadBuffer(Result, m.size);
    Result:=int(Result);
{$IFNDEF WIN32}
    Result := Result + DateFiddle;
{$ENDIF}
  end;
  m.Position := 0;
end;

function TQDBItem.GetDateTime(Index: integer): TDateTime;
var
  m: TMemoryStream;
begin
  Result := 0;
{$IFNDEF WIN32}
  Result := Result + DateFiddle;
{$ENDIF}
  if GetType(Index) <> ftdatetime then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size = SizeOf(Result) then
  begin
    m.ReadBuffer(Result, m.size);
{$IFNDEF WIN32}
    Result := Result + DateFiddle;
{$ENDIF}
  end;
  m.Position := 0;
end;

{ This function returns a pointer to the actual data }
{ of a field so use it with care. Don't construct or }
{ destroy the the variable you assign to and only    }
{ modify the returned stream if you really mean to!  }
{ You should also reset the data streams position to }
 { the beginning when you've finished with it.        }

function TQDBItem.GetField(Index: integer): TMemoryStream;
var
  ThisField: TFieldInfo;
begin
  if (Index >= 0) and (Index < Fields.Count) then
  begin
    ThisField := TFieldInfo(Fields.Objects[Index]);
    ThisField.TheData.Position := 0;
    Result := ThisField.TheData;
  end
  else
    raise EQDBFieldError.Create(SBadFieldIndex);
end;

function TQDBItem.GetInteger(Index: integer): longint;
var
  m: TMemoryStream;
begin
  Result := 0;
  if GetType(Index) <> ftinteger then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size = SizeOf(Result) then
    m.ReadBuffer(Result, m.size);
  m.Position := 0;
end;

function TQDBItem.GetName(Index: integer): string;
begin
  if Index < Fields.Count then
    Result := Fields[Index]
  else
    Result := ''
end;

function TQDBItem.GetReal(Index: integer): extended;
var
  m: TMemoryStream;
begin
  Result := 0;
  if GetType(Index) <> ftreal then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size = SizeOf(Result) then
    m.ReadBuffer(Result, m.size);
  m.Position := 0;
end;

function TQDBItem.GetString(Index: integer): string;
var
  m: TMemoryStream;
  p: pchar;
begin
  Result := '';
  if GetType(Index) <> ftstring then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size > 0 then
  begin
    p := StrAlloc(m.size);
    try
      m.Read(p^, 80);  {// just get the first 80 chars}
      Result := StrPas(p);
    finally
      StrDispose(p);
    end;
  end;
  m.Position := 0;
end;

function TQDBItem.GetStrings(Index: integer): string;
var
  m: TMemoryStream;
  p: pchar;
begin
  Result := '';
  if GetType(Index) <> ftstrings then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size > 0 then
  begin
    p := StrAlloc(m.size);
    try
      m.ReadBuffer(p^, m.size);
      Result := StrPas(p);
    finally
      StrDispose(p);
    end;
  end;
  m.Position := 0;
end;

function TQDBItem.GetTime(Index: integer): TDateTime;
var
  m: TMemoryStream;
begin
  Result := 0;
{$IFNDEF WIN32}
  Result := Result + DateFiddle;
{$ENDIF}
  if GetType(Index) <> fttime then
    raise EQDBFieldError.Create(SFieldCorrupt);
  m := GetField(Index);
  if m.size = SizeOf(Result) then
  begin
    m.ReadBuffer(Result, m.size);
    Result := frac(Result);
  end;
  m.Position := 0;
end;

function TQDBItem.GetType(Index: integer): TQDBFieldType;
begin
  if Index < Fields.Count then
    Result := TFieldInfo(Fields.Objects[Index]).TheType
  else
    Result := ftinteger;
end;

{ Enter inserting mode }

procedure TQDBItem.DoInsert;
begin
  inherited DoInsert;
  Clear;
end;

{ Call TQDB.LastItem and load the item }

procedure TQDBItem.LastItem;
begin
  if Ready then
  begin
    inherited LastItem;
    Fetch;
  end;
end;

{ Call TQDB.NextItem and load the item }

procedure TQDBItem.NextItem;
begin
  if Ready then
  begin
    inherited NextItem;
    Fetch;
  end;
end;

{ If we're editing or inserting Store the item }

procedure TQDBItem.DoPost;
begin
  if Ready then
  begin
    if Editing or Inserting then
    begin
      Store;
      inherited DoPost;
    end;
  end;
end;

{ Call TQDB.PrevItem and load the item }

procedure TQDBItem.PrevItem;
begin
  if Ready then
  begin
    inherited PrevItem;
    Fetch;
  end;
end;

procedure TQDBItem.Refresh;
begin
  if Ready then
  begin
    Fetch;
  end;
end;

{ The following routines Set a fields value converting as }
{ necesary.                                               }

procedure TQDBItem.SetAsBoolean(Index: integer; Value: boolean);
begin
  case GetType(Index) of
    ftinteger:
      if Value then
        SetInteger(Index, 1)
      else
        SetInteger(Index, 0);
    ftboolean: SetBoolean(Index, Value);
    ftstring:
      if Value then
        SetString(Index, 'TRUE')
      else
        SetString(Index, 'FALSE');
  else
    raise EQDBFieldError.Create(SInvalidFieldType);
  end;
end;

procedure TQDBItem.SetAsDate(Index: integer; const Value: TDateTime);
begin
  case GetType(Index) of
    ftreal: SetReal(Index, Value);
    ftstring: SetString(Index, FormatDateTime(DateTimeFormatStr, Value));
    ftdate: SetDate(Index, value);
    ftdatetime: SetDateTime(Index, Value);
  else
    raise EQDBFieldError.Create(SInvalidFieldType);
  end;
end;

procedure TQDBItem.SetAsDateTime(Index: integer; Value: TDateTime);
begin
  case GetType(Index) of
    ftreal: SetReal(Index, Value);
    ftstring: SetString(Index, FormatDateTime(DateTimeFormatStr, Value));
    ftdate: SetDate(Index, value);
    ftdatetime: SetDateTime(Index, Value);
    fttime: SetTime(Index, Value);
  else
    raise EQDBFieldError.Create(SInvalidFieldType);
  end;
end;

procedure TQDBItem.SetAsInteger(Index: integer; Value: longint);
begin
  case GetType(Index) of
    ftdate: SetDate(Index, 1.0*Value);
    ftinteger: SetInteger(Index, Value);
    ftreal: SetReal(Index, Value);
    ftboolean: SetBoolean(Index, Value > 0);
    ftstring: SetString(Index, IntToStr(Value));
  else
    raise EQDBFieldError.Create(SInvalidFieldType);
  end;
end;

procedure TQDBItem.SetAsReal(Index: integer; Value: extended);
begin
  case GetType(Index) of
    ftinteger: SetInteger(Index, Round(Value));
    ftreal: SetReal(Index, Value);
    ftstring: SetString(Index, FormatFloat(RealFormatStr, Value));
    ftdate: SetDate(Index, Value);
    ftdatetime: SetDateTime(Index, Value);
    fttime: SetTime(Index, Value);
  else
    raise EQDBFieldError.Create(SInvalidFieldType);
  end;
end;

procedure TQDBItem.SetAsString(Index: integer; const Value: string);
begin
  case GetType(Index) of
    ftinteger: SetInteger(Index, StrToInt(Value));
    ftreal: SetReal(Index, StrToFloat(Value));
    ftboolean: SetBoolean(Index, StrToBoolean(Value));
    ftstring: SetString(Index, Value);
    ftdate: SetDate(Index, StrToDateTime(Value));
    ftdatetime: SetDateTime(Index, StrToDateTime(Value));
    fttime: SetTime(Index, StrToDateTime(Value));
  else
    { do nothing
     raise EQDBFieldError.Create(SInvalidFieldType);}
  end;
end;

procedure TQDBItem.SetAsTime(Index: integer; Value: TDateTime);
begin
  case GetType(Index) of
    ftreal: SetReal(Index, Value);
    ftstring: SetString(Index, FormatDateTime(DateTimeFormatStr, Value));
    fttime: SetTime(Index, value);
    ftdatetime: SetDateTime(Index, Value);
  else
    raise EQDBFieldError.Create(SInvalidFieldType);
  end;
end;

{ The following routines set a field from its native type }

procedure TQDBItem.SetBoolean(Index: integer; Value: boolean);
var
  m: TMemoryStream;
begin
  m := GetField(Index);
  m.Clear;
  m.WriteBuffer(Value, SizeOf(Value));
  m.Position := 0;
end;

procedure TQDBItem.SetDate(Index: integer; Value: TDateTime);
var
  m: TMemoryStream;
begin
  m := GetField(Index);
  m.Clear;
  m.WriteBuffer(Value, SizeOf(Value));
  m.Position := 0;
end;

procedure TQDBItem.SetDateTime(Index: integer; Value: TDateTime);
var
  m: TMemoryStream;
begin
  m := GetField(Index);
  m.Clear;
  m.WriteBuffer(Value, SizeOf(Value));
  m.Position := 0;
end;

procedure TQDBItem.SetField(Index: integer; Stream: TMemoryStream);
var
  ThisData: TMemoryStream;
begin
  if (Index >= 0) and (Index < Fields.Count) then
  begin
    ThisData := TFieldInfo(Fields.Objects[Index]).TheData;
    ThisData.Clear;
    Stream.Position := 0;
    ThisData.CopyFrom(Stream, Stream.size);
    ThisData.Position := 0;
  end;
end;

procedure TQDBItem.SetInteger(Index: integer; Value: longint);
var
  m: TMemoryStream;
begin
  m := GetField(Index);
  m.Clear;
  m.WriteBuffer(Value, SizeOf(Value));
  m.Position := 0;
end;

procedure TQDBItem.SetReal(Index: integer; Value: extended);
var
  m: TMemoryStream;
begin
  m := GetField(Index);
  m.Clear;
  m.WriteBuffer(Value, SizeOf(Value));
  m.Position := 0;
end;

procedure TQDBItem.SetString(Index: integer; const Value: string);
var
  m: TMemoryStream;
  p: pchar;
  L: integer;
begin
  m := GetField(Index);
  L := Length(Value);
  p := StrAlloc(L + 1);
  try
    p[L] := #0;
    StrPCopy(p, Value);
    m.Clear;
    m.WriteBuffer(p^, L + 1);
    m.Position := 0;
  finally
    StrDispose(p);
  end;
end;

procedure TQDBItem.SetTime(Index: integer; Value: TDateTime);
var
  m: TMemoryStream;
begin
  m := GetField(Index);
  m.Clear;
  m.WriteBuffer(Value, SizeOf(Value));
  m.Position := 0;
end;

{ Compile all the fields into an item and store it.     }
{ An OnKey handler must have been assigned. The item is }
{ added or changed as necessary.                        }

procedure TQDBItem.Store;
var
  n: integer;
  ThisField: TFieldInfo;
  Len: longint;
  NewKey: TKey;
begin
  CurrentItem.Clear;
  for n := 1 to Fields.Count do
  begin
    ThisField := TFieldInfo(Fields.Objects[n - 1]);
    ThisField.TheData.Position := 0;
    Len := ThisField.TheData.size;
    CurrentItem.WriteBuffer(Len, SizeOf(Len));
    CurrentItem.CopyFrom(ThisField.TheData, Len);
    ThisField.TheData.Position := 0;
  end;
  if Assigned(FOnKey) then
    FOnKey(Self, NewKey)
  else
    raise EQDBKeyError.Create(SNoOnKey);
  if ExactMatch(NewKey) then
    Change(CurrentItem)
  else
  begin
    if not Inserting then
      inherited DoDelete;
    Add(CurrentItem, NewKey);
  end;
end;

{ Like Store only bypassing the OnKey handler. Will }
{ only store new items.                             }

procedure TQDBItem.StoreAs(NewKey: TKey);
var
  n: integer;
  ThisField: TFieldInfo;
  Len: longint;
begin
  CurrentItem.Clear;
  for n := 1 to Fields.Count do
  begin
    ThisField := TFieldInfo(Fields.Objects[n - 1]);
    ThisField.TheData.Position := 0;
    Len := ThisField.TheData.size;
    CurrentItem.WriteBuffer(Len, SizeOf(Len));
    CurrentItem.CopyFrom(ThisField.TheData, Len);
    ThisField.TheData.Position := 0;
  end;
  if NewKey <> '' then
  begin
    if not ExactMatch(NewKey) then
      Add(CurrentItem, NewKey);
  end;
end;

{ Stores the current field defintions in the file }

procedure TQDBItem.StoreStructure;
var
  n: integer;
  StructureInfo: string;
begin
  ClearStructure;
  for n := 1 to FieldCount do
    with TFieldInfo(Fields.Objects[n - 1]) do
    begin
      StructureInfo := chr(Byte(TheType)) + '.' + Fields[n - 1];
      AdminAsString[Format('%s%.4d', [StructureIndicator, n - 1])] := StructureInfo;
    end;
end;

{ TRegisteredControlList }

{ The reference list of what controls have been registered and }
{ how to use them.                                             }

constructor TRegisteredControlList.Create;
begin
  inherited Create;
end;

destructor TRegisteredControlList.Destroy;
var
  n: integer;
begin
  for n := 1 to Count do
    FreeMem(Items[n - 1], SizeOf(TRegistrationInfo));
  inherited Destroy;
end;

function TRegisteredControlList.GetRegistrationInfo(Instance: TControl; var RegistrationInfo: TRegistrationInfo): boolean;
var
  n: integer;
begin
  Result := false;
  for n := Count downto 1 do
  begin
    if Instance.InheritsFrom(TRegistrationInfo(Items[n - 1]^).AClass) then
    begin
      RegistrationInfo := TRegistrationInfo(Items[n - 1]^);
      Result := true;
      exit;
    end;
  end;
end;

{ For a control on a panel to be recognized by QDBView it must  }
{ have been registered via ths method.                           }
{ Registration associates with a class of control the procedures }
{ to clear, fetch, and store it.                                 }

procedure TRegisteredControlList.RegisterControl(AClass: TControlClass; FieldType: TQDBFieldType;
  ClearProc, FetchProc, StoreProc: TClassProc);
var
  i: ^TRegistrationInfo;
begin
  GetMem(i, SizeOf(TRegistrationInfo));
  i^.AClass := AClass;
  i^.AType := FieldType;
  @i^.ClearProc := @ClearProc;
  @i^.FetchProc := @FetchProc;
  @i^.StoreProc := @StoreProc;
  Add(i);
end;


{ TQDBView }

type
  TControlInfo = class
    TheControl: TControl;
    ClearProc: TClassProc;
    FetchProc: TClassProc;
    StoreProc: TClassProc;
  end;

constructor TQDBView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { the actual control info augmenting the field info in QDBItem }
  ControlList := TList.Create;
  { controls with this tag are not counted as fields }
  ExcludeTag := -999;
  { register the defualt control classes }
  RegisteredControls := TRegisteredControlList.Create;
  RegisterControl(TCustomEdit, ftstring, ClearCustomEdit, FetchCustomEdit, StoreCustomEdit);
{$IFDEF WIN32}
  RegisterControl(TRichEdit, ftrichstrings, ClearRichEdit, FetchRichEdit, StoreRichEdit);
{$ENDIF}
  RegisterControl(TCustomRadioGroup, ftinteger, ClearCustomRadioGroup, FetchCustomRadioGroup, StoreCustomRadioGroup);
  RegisterControl(TCustomCheckBox, ftinteger, ClearCustomCheckBox, FetchCustomCheckBox, StoreCustomCheckBox);
  RegisterControl(TCustomComboBox, ftstring, ClearCustomComboBox, FetchCustomComboBox, StoreCustomComboBox);
  RegisterControl(TCustomListBox, ftintegers, ClearCustomListBox, FetchCustomListBox, StoreCustomListBox);
  RegisterControl(TImage, ftgraphic, ClearImage, FetchImage, StoreImage);
  FActive := false;
  FActiveColor := clWindow;
  FInactiveColor := clSilver;
end;

destructor TQDBView.Destroy;
var
  n: integer;
  i: integer;
begin
  n := ControlList.Count;
  for i := n downto 1 do
  begin
    TControlInfo(ControlList[i - 1]).Free;
    ControlList.Delete(i - 1);
  end;
  ControlList.Free;
  RegisteredControls.Free;
  inherited Destroy;
end;

{ Checks each control on the associated panel and as they are }
{ recognized stores the info in the field and control lists.  }

procedure TQDBView.BuildFieldList;
var
  RegistrationInfo: TRegistrationInfo;
  NewProcs: TControlInfo;

  procedure ForEachControl(AWinControl: TWinControl); forward;

  procedure ProcessControl(ThisControl: TControl);
  begin
    { do nothing with a control if the tag is set to exclude them }
    if (ThisControl.Tag = ExcludeTag) then
      exit;
    { if the control owns others  ... }
    if (ThisControl is TWinControl) and (TWinControl(ThisControl).ControlCount <> 0) then
      ForEachControl(TWinControl(ThisControl))
    else
      if RegisteredControls.GetRegistrationInfo(ThisControl, RegistrationInfo) then
      begin
        AddField(ThisControl.Name, RegistrationInfo.AType);
        NewProcs := TControlInfo.Create;
        NewProcs.TheControl := ThisControl;
        @NewProcs.ClearProc := @RegistrationInfo.ClearProc;
        @NewProcs.FetchProc := @RegistrationInfo.FetchProc;
        @NewProcs.StoreProc := @RegistrationInfo.StoreProc;
        ControlList.Add(NewProcs);
      end;
  end;

  procedure ForEachControl(AWinControl: TWinControl);
  var
    n: integer;
  begin
{$IFDEF WIN32}
    if (AWinControl is TPageControl) then
      with (AWinControl as TPageControl) do
        for n := 1 to PageCount do
          ProcessControl(Pages[n - 1])
    else
{$ENDIF}
      for n := 1 to AWinControl.ControlCount do
        ProcessControl(AWinControl.Controls[n - 1]);
  end;

begin
  if FPanel <> nil then
  begin
    Fields.Clear;
    ControlList.Clear;
    ForEachControl(FPanel);
  end;
end;

procedure TQDBView.DoCancel;
begin
  if not AutoEdit then
    SetActive(false);
  if Ready then
  begin
    inherited DoCancel;
  end;
end;

{ Checks the field structure as defined by the associated panel }
{ against the field structure as stored in the associated file. }

function TQDBView.CheckStructure: boolean;
var
  n: integer;
  StructureInfo: string;
begin
  Result := false;
  for n := 1 to FieldCount do
  begin
    Result := true;
    with TFieldInfo(Fields.Objects[n - 1]) do
      with TControlInfo(ControlList[n - 1]) do
      begin
        StructureInfo := chr(Byte(TheType)) + '.' + Fields[n - 1] + '.' + TheControl.ClassName;
        if not ((AdminKeyExists(Format('%s%.4d', [StructureIndicator, n - 1])))
          and (AdminAsString[Format('%s%.4d', [StructureIndicator, n - 1])] = StructureInfo)) then
        begin
          Result := false;
          exit;
        end;
      end;
  end;
end;

procedure TQDBView.Clear;
var
  n: integer;
begin
  inherited Clear;
  for n := 1 to FieldCount do
    with TControlInfo(ControlList[n - 1]) do
      ClearProc(TheControl, nil);
end;

{ REmoves all record of the field structure from the file }

procedure TQDBView.ClearStructure;
begin
  AdminClear(StructureIndicator);
end;

procedure TQDBView.DoDelete;
begin
  if Ready then
  begin
    if not AutoEdit then
      SetActive(false);
    inherited DoDelete;
  end;
end;

procedure TQDBView.DoEdit;
begin
  if Ready then
  begin
    SetActive(true);
    Refresh; { ??? }
    inherited DoEdit;
  end;
end;

{ Calls TQDBItem.Fetch to load and parse the item and then }
{ displays the fields in the controls.                     }

procedure TQDBView.Fetch;
var
  n: integer;
begin
  inherited Fetch;
  if Count > 0 then
  begin
    for n := 1 to FieldCount do
      with TControlInfo(ControlList[n - 1]) do
        with TFieldInfo(Fields.Objects[n - 1]) do
        begin
          TheData.Position := 0;
          FetchProc(TheControl, TheData);
          TheData.Position := 0;
        end;
    FocusFirstTab;
  end;
end;

{ Checks if the file contains field definitions }

function TQDBView.FileIsStructured: boolean;
begin
  Result := AdminKeyExists(Format('%s%.4d', [StructureIndicator, 0]));
end;

{ If the file isn't structured or if it empty the new structure }
{ is stored in the file, otherwise the structrue is checked.    }

function TQDBView.FileMatchesPanel: boolean;
begin
  Result := true;
  if Ready and (FPanel <> nil) then
  begin
    if not FileIsStructured then
      StoreStructure
    else
    begin
      if not CheckStructure then
      begin
        if Count > 0 then
        begin
          Result := false;
        end
        else
        begin
          StoreStructure;
        end;
      end;
    end;
  end;
end;

procedure TQDBView.FirstItem;
begin
  if Ready then
  begin
    inherited FirstItem;
  end;
end;

{ Puts the focus on the first control in the tab order }
type
  TWinControlHack = class(TWinControl);

procedure TQDBView.FocusFirstTab;
var
  First: TWinControl;
begin
  if FActive and (FPanel <> nil) then
  begin
    First := TWinControlHack(FPanel).FindNextControl(nil, true, true, false);
    if (First <> nil) then
      First.SetFocus;
  end;
end;

procedure TQDBView.DoInsert;
begin
  if Ready then
  begin
    SetActive(true);
    FocusFirstTab;
    inherited DoInsert;
  end;
end;

procedure TQDBView.LastItem;
begin
  if Ready then
  begin
    inherited LastItem;
  end;
end;

procedure TQDBView.Loaded;
var
  n: integer;
  c: TWinControl;
begin
  if FPanel = nil then
    exit;
  for n := 1 to FieldCount do
  begin
    c := TWinControl(TControlInfo(ControlList[n - 1]).TheControl);
    PostMessage(c.Handle, em_setReadOnly, integer(not FActive), 0);
  end;
end;

procedure TQDBView.NextItem;
begin
  if Ready then
  begin
    inherited NextItem;
  end;
end;

{ Makessure that if the associated panel is removed its reference }
{ is also removed.                                                }

procedure TQDBView.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (FPanel <> nil) and
    (AComponent = FPanel) and
    (Operation = opRemove) then
  begin
    FPanel := nil;
  end;
end;

procedure TQDBView.DoPost;
begin
  if Ready then
  begin
    if FActive then
      inherited DoPost;
    if not AutoEdit then
      SetActive(false);
  end;
end;

procedure TQDBView.PrevItem;
begin
  if Ready then
  begin
    inherited PrevItem;
  end;
end;

procedure TQDBView.Refresh;
begin
  if Ready then
  begin
    inherited Refresh;
  end;
end;

procedure TQDBView.RegisterControl(AClass: TControlClass; FieldType: TQDBFieldType;
  ClearProc, FetchProc, StoreProc: TClassProc);
begin
  RegisteredControls.RegisterControl(AClass, FieldType, ClearProc, FetchProc, StoreProc);
end;

{ By default Delphi recognizes bmp, wmf, and ico formats but }
{ others (like jpg) can be registered via the Graphics unit. }
{ If you want QDBView to also handle them they must be      }
{ registered here too.                                       }

procedure TQDBView.RegisterGraphicFormat(const AExtension: string; AGraphicClass: TGraphicClass);
var
  NewRec: PFileFormat;
begin
  New(NewRec);
  with NewRec^ do
  begin
    Extension := LowerCase(AExtension);
    GraphicClass := AGraphicClass;
    Next := FileFormatList;
  end;
  FileFormatList := NewRec;
end;

{ The color of a control's background when editing or inserting }

procedure TQDBView.SetActiveColor(Value: TColor);
begin
  if FActiveColor <> Value then
  begin
    FActiveColor := Value;
    SetActive(FActive);
  end;
end;

type
  THackControl = class(TControl);

  { Active covers both editing and inserting. }

procedure TQDBView.SetActive(Value: boolean);
var
  n: integer;
  c: THackControl;
begin
  FActive := Value;
  if FPanel = nil then
    exit;
  LockWindowUpdate(FPanel.Handle);
  try
    for n := 1 to FieldCount do
    begin
      c := THackControl(TControlInfo(ControlList[n - 1]).TheControl);
      if Value then
      begin
        c.Color := ActiveColor;
        c.Perform(em_setReadOnly, 0, 0);
      end
      else
      begin
        c.Color := InactiveColor;
        c.Perform(em_setReadOnly, 1, 0);
      end;
    end;
  finally
    LockWindowUpdate(0);
  end;
end;

{ Note that the structure-check only occurs at run-time }

procedure TQDBView.SetFileName(Value: TQDBFileName);
begin
  inherited SetFileName(Value);
  if Ready and (Count > 0) then
    FirstItem;
  if not FileMatchesPanel then
  begin
    SetFileName('');
    raise EQDBViewError.Create(SBadMatch);
  end;
end;

procedure TQDBView.SetInactiveColor(Value: TColor);
begin
  if FInactiveColor <> Value then
  begin
    FInactiveColor := Value;
    SetActive(FActive);
  end;
end;

{ Sets the associated panel and rebuilds the field and  }
{ control lists.                                        }

procedure TQDBView.SetPanel(Value: TCustomPanel);
begin
  FPanel := Value;
  BuildFieldList;
  if Ready and (Count > 0) then
    FirstItem;
  SetActive(AutoEdit);
  if not FileMatchesPanel then
  begin
    SetPanel(nil);
    raise EQDBViewError.Create(SBadMatch);
  end;
end;

procedure TQDBView.Store;
var
  n: integer;
begin
  for n := 1 to FieldCount do
    with TControlInfo(ControlList[n - 1]) do
      with TFieldInfo(Fields.Objects[n - 1]) do
      begin
        TheData.Clear;
        StoreProc(TheControl, TheData);
        TheData.Position := 0;
      end;
  inherited Store;
end;

procedure TQDBView.StoreStructure;
var
  n: integer;
  StructureInfo: string;
begin
  if ReadOnly then
    Exit;
  ClearStructure;
  for n := 1 to FieldCount do
    with TFieldInfo(Fields.Objects[n - 1]) do
      with TControlInfo(ControlList[n - 1]) do
      begin
        StructureInfo := chr(Byte(TheType)) + '.' + Fields[n - 1] + '.' + TheControl.ClassName;
        AdminAsString[Format('%s%.4d', [StructureIndicator, n - 1])] := StructureInfo;
      end;
end;

end.