Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/QDB/QDBP.ZIP/qdbpanel.pas

Pascal/Delphi Source File | 1998-07-29 | 18.0 KB | 789 lines

(*

QDBPanel v2.00 Beta Release 3
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

This is the third beta release of QDBPanel for QDB v2.00. QDB itself is
now ready for release but QDBPanel remains in beta for a while longer as
certain design issues still need to be addressed.

There is no help file for this release -- this file will have to serve
for the moment. Although I have decided to release the source code for
this beta version please bear in mind that it will change greatly from
version to version. I will, however, try to keep the interface
functionally the same and the file structure unchanged.

Please be aware that you are quite likely to find bugs or other problems.
Please let me know about them at [e-mail]. Thanks for your help.
If you have any ideas for QDBPanel send them along too. A related
component, QDBGrid, is still in the alpha stage.

QDBPanel, which remains free, is Copyright (c) 1997 Robert R. Marsh, SJ &
the British Province of the Society of Jesus.

*)

{$F+}

unit QDBPanel;

interface

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

type
  TClassProc = procedure(AControl: TControl; Stream: TStream);
  TKeyEvent = procedure(Sender: TObject; var key: TKey) of object;

type
  TProcKind = (pkClear, pkFetch, pkStore);

type
  TProcList = class(TList)
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddProcs(AClass: TControlClass; ClearProc, FetchProc, StoreProc: TClassProc);
    function GetProc(Instance: TControl; ProcKind: TProcKind): TClassProc;
  end;

type
  TFieldList = class(TStringList)
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddField(ThisControl: TControl; ClearProc, FetchProc, StoreProc: TClassProc);
  end;

type
  TQDBPanel = class(TPanel)
  private
    Fields: TFieldList;
    Procs: TProcList;
    CurrentItem: TMemoryStream;
    FEnabled: boolean;
    FExcludeTag: longint;
    FQDB: TQDB;
    FOnKey: TKeyEvent;
  protected
    procedure Loaded; override;
    procedure BuildFieldList;
    procedure SetEnabled(value: boolean);
    function GetCount: integer;
{    function GetField(index: integer): TStream;}
    function GetName(index: integer): string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure RegisterProcs(AClass: TControlClass; ClearProc, FetchProc, StoreProc: TClassProc);
    procedure RegisterGraphicFormat(const AExtension: string; AGraphicClass: TGraphicClass);
    procedure Clear;
    procedure Fetch;
    procedure Store;
    procedure Cancel;
    procedure Delete;
    procedure Edit;
    procedure FirstItem;
    procedure Insert;
    procedure LastItem;
    procedure NextItem;
    procedure Post;
    procedure PrevItem;
    procedure Refresh;
    property FieldCount: integer read GetCount;
    property FieldNames[index: integer]: string read GetName; default;
  published
    property Enabled: boolean read FEnabled write SetEnabled;
    property ExcludeTag: longint read FExcludeTag write FExcludeTag;
    property QDB: TQDB read FQDB write FQDB;
    property OnKey: TKeyEvent read FOnKey write FOnKey;
  end;

implementation

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

{ Default control handlers registered in TQDBPanel.Create }

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

procedure FetchCustomEdit(AControl: TControl; Stream: TStream);
var
  con: TCustomEdit;
  p: pchar;
begin
  con := (AControl as TCustomEdit);
  p := StrAlloc(Stream.Size);
  try
    Stream.ReadBuffer(p^, Stream.Size);
    con.SetTextBuf(p);
  finally
    StrDispose(p);
  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}

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

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

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

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

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

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

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

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

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

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

procedure FetchCustomComboBox(AControl: TControl; Stream: TStream);
var
  p: pchar;
begin
  p := StrAlloc(Stream.Size);
  try
    Stream.ReadBuffer(p^, Stream.Size);
    (Acontrol as TCustomComboBox).SetTextBuf(p);
    ;
  finally
    StrDispose(p);
  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;

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

procedure FetchCustomListBox(AControl: TControl; Stream: TStream);
var
  con: TCustomListBox;
  n: longint;
begin
  con := (AControl as TCustomListBox);
  for n := 1 to con.Items.Count do
  begin
    con.Selected[n - 1] := false;
  end;
  while true do
  begin
    Stream.ReadBuffer(n, SizeOf(longint));
    if (n < 0) or (n > con.Items.Count) then
      Break;
    con.Selected[n] := true;
  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;

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

procedure FetchImage(AControl: TControl; Stream: TStream);
var
  con: TImage;
  ext: array[0..3] of char;
  Graphic: PFileFormat;
  NewGraphic: TGraphic;
begin
  con := (AControl as TImage);
  ext[3] := #0;
  Stream.ReadBuffer(ext[0], 3);
  Graphic := FileFormatList;
  while Graphic <> nil do
    with Graphic^ do
    begin
      if Extension <> StrPas(Ext) then
        Graphic := Next
      else
      begin
        NewGraphic := GraphicClass.Create;
        try
          try
            NewGraphic.LoadFromStream(Stream);
          except
            NewGraphic.Free;
            raise;
          end;
          con.Picture.Assign(NewGraphic);
          Exit;
        finally
          NewGraphic.Free;
        end;
      end;
    end;
  raise Exception.Create('invalid graphic format');
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('unknown graphic class');
end;

{ TProcList }

type
  TInfo = record
    AClass: TControlClass;
    ClearProc: TClassProc;
    FetchProc: TClassProc;
    StoreProc: TClassProc;
  end;

constructor TProcList.Create;
begin
  inherited Create;
end;

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

procedure TProcList.AddProcs(AClass: TControlClass; ClearProc, FetchProc, StoreProc: TClassProc);
var
  i: ^TInfo;
begin
  GetMem(i, SizeOf(TInfo));
  i^.AClass := AClass;
  @i^.ClearProc := @ClearProc;
  @i^.FetchProc := @FetchProc;
  @i^.StoreProc := @StoreProc;
  Add(i);
end;

function TProcList.GetProc(Instance: TControl; ProcKind: TProcKind): TClassProc;
var
  n: integer;
begin
  for n := Count downto 1 do
  begin
    with TInfo(Items[n - 1]^) do
    begin
      if Instance.InheritsFrom(AClass) then
      begin
        case ProcKind of
          pkClear:
            @Result := @TClassProc(ClearProc);
          pkFetch:
            @Result := @TClassProc(FetchProc);
          pkStore:
            @Result := @TClassProc(StoreProc);
        else
          @Result := nil
        end;
        Exit;
      end;
    end;
  end;
  Result := nil;
end;

{ TFieldList }

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

constructor TFieldList.Create;
begin
  inherited Create;
  Sorted := false;
end;

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

procedure TFieldList.AddField(ThisControl: TControl; ClearProc, FetchProc, StoreProc: TClassProc);
var
  i: TFieldInfo;
begin
  i := TFieldInfo.Create;
  i.TheControl := ThisControl;
  @i.ClearProc := @ClearProc;
  @i.FetchProc := @FetchProc;
  @i.StoreProc := @StoreProc;
  AddObject(ThisControl.Name, i);
end;


{ TQDBPanel }

constructor TQDBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ExcludeTag := -999;
  Caption := '';
  Fields := TFieldList.Create;
  Procs := TProcList.Create;
  CurrentItem := TMemoryStream.Create;
{ Register the storage mechanism for default control types }
{ Entries later in the list override ones earlier          }
  RegisterProcs(TCustomEdit, ClearCustomEdit, FetchCustomEdit, StoreCustomEdit);
{$IFDEF WIN32}
  RegisterProcs(TRichEdit, ClearRichEdit, FetchRichEdit, StoreRichEdit);
{$ENDIF}
  RegisterProcs(TCustomRadioGroup, ClearCustomRadioGroup, FetchCustomRadioGroup, StoreCustomRadioGroup);
  RegisterProcs(TCustomCheckBox, ClearCustomCheckBox, FetchCustomCheckBox, StoreCustomCheckBox);
  RegisterProcs(TCustomComboBox, ClearCustomComboBox, FetchCustomComboBox, StoreCustomComboBox);
  RegisterProcs(TCustomListBox, ClearCustomListBox, FetchCustomListBox, StoreCustomListBox);
  RegisterProcs(TImage, ClearImage, FetchImage, StoreImage);
  Enabled := false;
end;

destructor TQDBPanel.Destroy;
begin
  CurrentItem.Free;
  Fields.Free;
  Procs.Free;
  inherited Destroy;
end;

procedure TQDBPanel.Loaded;
begin
  BuildFieldList;
end;

procedure TQDBPanel.BuildFieldList;

  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 a control owns others  ... }
    if (ThisControl is TWinControl) and (TWinControl(ThisControl).ControlCount <> 0) then
    begin
        { if it's the original QDBPanel or not a QDBPanel at all }
      if (ThisControl.Name = Name) or not (ThisControl is TQDBPanel) then
        ForEachControl(TWinControl(ThisControl));
    end
    else
    begin
        { it's an ordinary control }
      Fields.AddField(ThisControl, Procs.GetProc(ThisControl, pkClear),
                                   Procs.GetProc(ThisControl, pkFetch),
                                   Procs.GetProc(ThisControl, pkStore));
    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
  ForEachControl(self);
end;

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

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

procedure TQDBPanel.SetEnabled(value: boolean);
var
  n: integer;
begin
  for n := 1 to Fields.Count do
  begin
    TFieldInfo(Fields.Objects[n - 1]).TheControl.Enabled := value;
  end;
  FEnabled := value;
end;

procedure TQDBPanel.Clear;
var
  n: integer;
  ThisTypeProc: TClassProc;
  ThisControl: TControl;
begin
  for n := 1 to Fields.Count do
  begin
    ThisControl := TFieldInfo(Fields.Objects[n - 1]).TheControl;
    ThisTypeProc := TFieldInfo(Fields.Objects[n - 1]).ClearProc;
    if @ThisTypeProc <> nil then ThisTypeProc(ThisControl, nil);
  end;
  CurrentItem.Clear;
end;

procedure TQDBPanel.Fetch;
var
  n: integer;
  m: TMemoryStream;
  ThisControl: TControl;
  ThisTypeProc: TClassProc;
  len: longint;
begin
  if FQDB.Count > 0 then
  begin
    CurrentItem.Clear;
    FQDB.Get(CurrentItem);
    for n := 1 to Fields.Count do
    begin
      ThisControl := TFieldInfo(Fields.Objects[n - 1]).TheControl;
      ThisTypeProc := TFieldInfo(Fields.Objects[n - 1]).FetchProc;
      if @ThisTypeProc <> nil then
      begin
        m := TMemoryStream.Create;
        try
          CurrentItem.ReadBuffer(len, SizeOf(len));
          m.CopyFrom(CurrentItem, len);
          m.Position := 0;
          ThisTypeProc(ThisControl, m);
        finally
          m.Free;
        end;
      end;
    end;
  end;
end;

procedure TQDBPanel.Store;
var
  n: integer;
  m: TMemoryStream;
  ThisControl: TControl;
  ThisTypeProc: TClassProc;
  len: longint;
  Key: TKey;
begin
  CurrentItem.Clear;
  for n := 1 to Fields.Count do
  begin
    ThisControl := TFieldInfo(Fields.Objects[n - 1]).TheControl;
    ThisTypeProc := TFieldInfo(Fields.Objects[n - 1]).StoreProc;
    if @ThisTypeProc <> nil then
    begin
      m := TMemoryStream.Create;
      try
        ThisTypeProc(ThisControl, m);
        m.Position := 0;
        len := m.Size;
        CurrentItem.WriteBuffer(len, SizeOf(len));
        CurrentItem.CopyFrom(m, len);
      finally
        m.Free;
      end;
    end;
  end;
  if Assigned(FOnKey) then
    FOnKey(Self, Key)
  else
    Key := '';
  if Key <> '' then
  begin
    if FQDB.ExactMatch(Key) then
    begin
      FQDB.Change(CurrentItem);
    end
    else
    begin
      FQDB.Add(CurrentItem, Key);
    end;
  end;
end;

procedure TQDBPanel.RegisterProcs(AClass: TControlClass; ClearProc, FetchProc, StoreProc: TClassProc);
begin
  Procs.AddProcs(AClass, ClearProc, FetchProc, StoreProc);
end;

procedure TQDBPanel.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;

procedure TQDBPanel.Cancel;
begin
  Enabled := false;
  if Assigned(FQDB) then
  begin
    Fetch;
  end;
end;

procedure TQDBPanel.Delete;
begin
  if Assigned(FQDB) then
  begin
    Enabled := false;
    FQDB.Delete;
    Fetch;
  end;
end;

procedure TQDBPanel.Edit;
begin
  Enabled := true;
end;

procedure TQDBPanel.FirstItem;
begin
  if Assigned(FQDB) then
  begin
    FQDB.FirstItem;
    Fetch;
  end;
end;

procedure TQDBPanel.Insert;
begin
  Enabled := true;
  Clear;
end;

procedure TQDBPanel.LastItem;
begin
  if Assigned(FQDB) then
  begin
    FQDB.LastItem;
    Fetch;
  end;
end;

procedure TQDBPanel.NextItem;
begin
  if Assigned(FQDB) then
  begin
    FQDB.NextItem;
    Fetch;
  end;
end;

procedure TQDBPanel.Post;
begin
  if Assigned(FQDB) and Assigned(FOnKey) then
  begin
    if Enabled then
      Store;
    Enabled := false;
  end;
end;

procedure TQDBPanel.PrevItem;
begin
  if Assigned(FQDB) then
  begin
    FQDB.PrevItem;
    Fetch;
  end;
end;

procedure TQDBPanel.Refresh;
begin
  if Assigned(FQDB) then
  begin
    Fetch;
  end;
end;

end.