Package Structure

• MdDsList.pas
• MdDsCustom.pas
• MdDsDir.pas
• MdDsStream.pas
• MdDbGrid.pas
• MdRView.pas
• MdRepPr.pas
• MdProgr.pas
• MdTrack.pas

unit MdDsList;

interface

uses
  DB, Classes, SysUtils, Windows, Forms, Contnrs, MdDsCustom;

type
  TMdListDataSet = class (TMdCustomDataSet)
  protected
    // the list holding the data
    FList: TObjectList;
    // dataset virtual methods
    procedure InternalPreOpen; override;
    procedure InternalClose; override;
    // custom dataset virtual methods
    function InternalRecordCount: Integer; override;
    procedure InternalLoadCurrentRecord (Buffer: PChar); override;
  end;

implementation

procedure TMdListDataSet.InternalPreOpen;
begin
  FList := TObjectList.Create (True); // owns objects
  FRecordSize := 4; // an integer, the list item id
end;

procedure TMdListDataSet.InternalClose;
begin
  FList.Free;
  inherited;
end;

procedure TMdListDataSet.InternalLoadCurrentRecord (Buffer: PChar);
begin
  PInteger (Buffer)^ := fCurrentRecord;
  with PMdRecInfo(Buffer + FRecordSize)^ do
  begin
    BookmarkFlag := bfCurrent;
    Bookmark := fCurrentRecord;
  end;
end;

function TMdListDataSet.InternalRecordCount: Integer;
begin
  Result := fList.Count;
end;

end.

unit MdDsCustom;

interface

uses
  SysUtils, Classes, Db;

type
  EMdDataSetError = class (Exception);

  TMdRecInfo = record
    Bookmark: Longint;
    BookmarkFlag: TBookmarkFlag;
  end;
  PMdRecInfo = ^TMdRecInfo;

  TMdCustomDataSet = class(TDataSet)
  protected
    // status
    FIsTableOpen: Boolean;

    // record data
    FRecordSize, // the size of the actual data
    FRecordBufferSize, // data + housekeeping (TRecInfo)
    FCurrentRecord, // current record (0 to FRecordCount - 1)
    BofCrack, // before the first record (crack)
    EofCrack: Integer; // after the last record (crack)

    // create, close, and so on
    procedure InternalOpen; override;
    procedure InternalClose; override;
    function IsCursorOpen: Boolean; override;

    // custom functions
    function InternalRecordCount: Integer; virtual; abstract;
    procedure InternalPreOpen; virtual;
    procedure InternalAfterOpen; virtual;
    procedure InternalLoadCurrentRecord(Buffer: PChar); virtual; abstract;

    // memory management
    function AllocRecordBuffer: PChar; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    function GetRecordSize: Word; override;

    // movement and optional navigation (used by grids)
    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;
    procedure InternalFirst; override;
    procedure InternalLast; override;
    function GetRecNo: Longint; override;
    function GetRecordCount: Longint; override;
    procedure SetRecNo(Value: Integer); override;

    // bookmarks
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;

    // editing (dummy vesions)
    procedure InternalDelete; override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalPost; override;

    // other
    procedure InternalHandleException; override;
  published
    // redeclared data set properties
    property Active;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;
  end;


implementation

/////////////////////////////////////////////////
////// Part I:
////// Initialization, opening, and closing
/////////////////////////////////////////////////

// I: open the dataset
procedure TMDCustomDataSet.InternalOpen;
begin
  InternalPreOpen; // custom method for subclasses

  // initialize the field definitions
  // (another virtual abstract method of TDataSet)
  InternalInitFieldDefs;

  // if there are no persistent field objects,
  // create the fields dynamically
  if DefaultFields then
    CreateFields;
  // connect the TField objects with the actual fields
  BindFields (True);

  InternalAfterOpen; // custom method for subclasses

  // sets cracks and record position and size
  BofCrack := -1;
  EofCrack := InternalRecordCount;
  FCurrentRecord := BofCrack;
  FRecordBufferSize := FRecordSize + sizeof (TMdRecInfo);
  BookmarkSize := sizeOf (Integer);

  // everything OK: table is now open
  FIsTableOpen := True;
end;

procedure TMDCustomDataSet.InternalClose;
begin
  // disconnet field objects
  BindFields (False);
  // destroy field object (if not persistent)
  if DefaultFields then
    DestroyFields;

  // close the file
  FIsTableOpen := False;
end;

// I: is table open
function TMDCustomDataSet.IsCursorOpen: Boolean;
begin
  Result := FIsTableOpen;
end;

////////////////////////////////////////
////// Part II:
////// Bookmarks management and movement
////////////////////////////////////////

// II: set the requested bookmark as current record
procedure TMDCustomDataSet.InternalGotoBookmark (Bookmark: Pointer);
var
  ReqBookmark: Integer;
begin
  ReqBookmark := PInteger (Bookmark)^;
  if (ReqBookmark >= 0) and (ReqBookmark < InternalRecordCount) then
    FCurrentRecord := ReqBookmark
  else
    raise EMdDataSetError.Create ('Bookmark ' +
      IntToStr (ReqBookmark) + ' not found');
end;

// II: same as above (but passes a buffer)
procedure TMDCustomDataSet.InternalSetToRecord (Buffer: PChar);
var
  ReqBookmark: Integer;
begin
  ReqBookmark := PMdRecInfo(Buffer + FRecordSize).Bookmark;
  InternalGotoBookmark (@ReqBookmark);
end;

// II: retrieve bookmarks flags from buffer
function TMDCustomDataSet.GetBookmarkFlag (
  Buffer: PChar): TBookmarkFlag;
begin
  Result := PMdRecInfo(Buffer + FRecordSize).BookmarkFlag;
end;

// II: change the bookmark flags in the buffer
procedure TMDCustomDataSet.SetBookmarkFlag (Buffer: PChar;
  Value: TBookmarkFlag);
begin
  PMdRecInfo(Buffer + FRecordSize).BookmarkFlag := Value;
end;

// II: Go to a special position before the first record
procedure TMDCustomDataSet.InternalFirst;
begin
  FCurrentRecord := BofCrack;
end;

// II: Go to a special position after the last record
procedure TMDCustomDataSet.InternalLast;
begin
  EofCrack := InternalRecordCount;
  FCurrentRecord := EofCrack;
end;

// II: read the bookmark data from record buffer
procedure TMDCustomDataSet.GetBookmarkData (
  Buffer: PChar; Data: Pointer);
begin
  PInteger(Data)^ :=
    PMdRecInfo(Buffer + FRecordSize).Bookmark;
end;

// II: set the bookmark data in the buffer
procedure TMDCustomDataSet.SetBookmarkData (
  Buffer: PChar; Data: Pointer);
begin
  PMdRecInfo(Buffer + FRecordSize).Bookmark :=
    PInteger(Data)^;
end;

// II (optional): Record count
function TMDCustomDataSet.GetRecordCount: Longint;
begin
  CheckActive;
  Result := InternalRecordCount;
end;

// II (optional): Get the number of the current record
function TMDCustomDataSet.GetRecNo: Longint;
begin
  UpdateCursorPos;
  if FCurrentRecord < 0 then
    Result := 1
  else
    Result := FCurrentRecord + 1;
end;

// II (optional): Move to the given record number
procedure TMDCustomDataSet.SetRecNo(Value: Integer);
begin
  CheckBrowseMode;
  if (Value >= 1) and (Value <= InternalRecordCount) then
  begin
    FCurrentRecord := Value - 1;
    Resync([]);
  end;
end;

//////////////////////////////////////////
////// Part III:
////// Record buffers and field management
//////////////////////////////////////////

// III: Retrieve data for current, previous, or next record
// (eventually moving to it) and return the status
function TMDCustomDataSet.GetRecord(Buffer: PChar;
  GetMode: TGetMode; DoCheck: Boolean): TGetResult;
begin
  Result := grOK; // default
  case GetMode of
    gmNext: // move on
      if FCurrentRecord < InternalRecordCount - 1 then
        Inc (FCurrentRecord)
      else
        Result := grEOF; // end of file
    gmPrior: // move back
      if FCurrentRecord > 0 then
        Dec (FCurrentRecord)
      else
        Result := grBOF; // begin of file
    gmCurrent: // check if empty
      if FCurrentRecord >= InternalRecordCount then
        Result := grError;
  end;
  // load the data
  if Result = grOK then
    InternalLoadCurrentRecord (Buffer)
  else
    if (Result = grError) and DoCheck then
      raise EMdDataSetError.Create ('GetRecord: Invalid record');
end;

// III: Initialize the record (set to 0)
procedure TMDCustomDataSet.InternalInitRecord(Buffer: PChar);
begin
  FillChar(Buffer^, FRecordBufferSize, 0);
end;

// III: Free the buffer
procedure TMDCustomDataSet.FreeRecordBuffer (var Buffer: PChar);
begin
  FreeMem (Buffer);
end;

/// III: Determine the size of each record buffer in memory
function TMDCustomDataSet.GetRecordSize: Word;
begin
  Result := FRecordSize; // data only
end;

/// III: Allocate a buffer for the record
function TMDCustomDataSet.AllocRecordBuffer: PChar;
begin
  GetMem (Result, FRecordBufferSize);
end;

// III: Delete the current record
procedure TMDCustomDataSet.InternalDelete;
begin
  // not supported in this generic version
  raise EMdDataSetError.Create ('Delete: Operation not supported');
end;

// default exception handling

procedure TMDCustomDataSet.InternalHandleException;
begin
  // special purpose exception handling
  // do nothing
end;

procedure TMdCustomDataSet.InternalAddRecord(Buffer: Pointer;
  Append: Boolean);
begin
  // not supported in this generic version
  raise EMdDataSetError.Create ('AddRecord: Operation not supported');
end;

procedure TMdCustomDataSet.InternalPost;
begin
  // not supported in this generic version
  raise EMdDataSetError.Create ('Post: Operation not supported');
end;

procedure TMdCustomDataSet.InternalAfterOpen;
begin
  // nothing to do: subclasses can hook in here
end;

procedure TMdCustomDataSet.InternalPreOpen;
begin
  // nothing to do: subclasses can hook in here
end;

end.

unit MdDsDir;

interface

uses
  SysUtils, Classes, Db, MdDsList, MdDsCustom;

type
  TMdDirDataset = class(TMdListDataSet)
  private
    FDirectory: string;
    procedure SetDirectory(const NewDirectory: string);
  protected
    // TDataSet virtual methdos
    procedure InternalInitFieldDefs; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    function GetCanModify: Boolean; override;
    // custom dataset virtual methods
    procedure InternalAfterOpen; override;
  public
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  published
    property Directory: string read FDirectory write SetDirectory;
  end;

  TFileData = class
  public
    ShortFileName: string;
    Time: TDateTime;
    Size: Integer;
    Attr: Integer;
    constructor Create (var FileInfo: TSearchRec);
  end;

  procedure Register;

implementation

uses
  TypInfo, Dialogs, Windows, Forms, Controls;

procedure TMdDirDataset.SetDirectory(const NewDirectory: string);
begin
  if FIsTableOpen then
      raise Exception.Create ('Cannot change directory while dataset is open');
  fDirectory := NewDirectory;
end;

procedure TMdDirDataset.InternalAfterOpen;
var
  Attr: Integer;
  FileInfo: TSearchRec;
  FileData: TFileData;
begin
  // scan all files
  Attr := faAnyFile;
  FList.Clear;
  if SysUtils.FindFirst(fDirectory, Attr, FileInfo) = 0 then
  repeat
    FileData := TFileData.Create (FileInfo);
    FList.Add (FileData);
  until SysUtils.FindNext(FileInfo) <> 0;
  SysUtils.FindClose(FileInfo);
end;

procedure TMdDirDataset.InternalInitFieldDefs;
begin
  if fDirectory = '' then
    raise EMdDataSetError.Create ('Missing directory');

  // field definitions
  FieldDefs.Clear;
  FieldDefs.Add ('FileName', ftString, 40, True);
  FieldDefs.Add ('TimeStamp', ftDateTime);
  FieldDefs.Add ('Size', ftInteger);
  FieldDefs.Add ('Attributes', ftString, 3);
  FieldDefs.Add ('Folder', ftBoolean);
end;

// support function
function DateTimeToNative(DataType: TFieldType; Data: TDateTime): TDateTimeRec;
var
  TimeStamp: TTimeStamp;
begin
  TimeStamp := DateTimeToTimeStamp(Data);
  case DataType of
    ftDate: Result.Date := TimeStamp.Date;
    ftTime: Result.Time := TimeStamp.Time;
  else
    Result.DateTime := TimeStampToMSecs(TimeStamp);
  end;
end;

function TMdDirDataset.GetFieldData (
  Field: TField; Buffer: Pointer): Boolean;
var
  FileData: TFileData;
  Bool1: WordBool;
  strAttr: string;
  t: TDateTimeRec;
begin
  FileData := fList [PInteger(ActiveBuffer)^] as TFileData;
  case Field.Index of
    0: // filename
      StrCopy (Buffer, pchar(FileData.ShortFileName));
    1: // timestamp
    begin
      t := DateTimeToNative (ftdatetime, FileData.Time);
      Move (t, Buffer^, sizeof (TDateTime));
    end;
    2:  // size
      Move (FileData.Size, Buffer^, sizeof (Integer));
    3: begin // attributes
      strAttr := '   ';
      if (FileData.Attr and SysUtils.faReadOnly) > 0 then
        strAttr [1] := 'R';
      if (FileData.Attr and SysUtils.faSysFile) > 0 then
        strAttr [2] := 'S';
      if (FileData.Attr and SysUtils.faHidden) > 0 then
        strAttr [3] := 'H';
      StrCopy (Buffer, pchar(strAttr));
    end;
    4: begin // folder
      Bool1 := FileData.Attr and SysUtils.faDirectory > 0;
      Move (Bool1, Buffer^, sizeof (WordBool));
    end;
  end; // case
  Result := True;
end;

// III: Move data from field to record buffer
procedure TMdDirDataset.SetFieldData(Field: TField; Buffer: Pointer);
begin
  // read only: nothing to todo
end;

function TMdDirDataset.GetCanModify: Boolean;
begin
  Result := False; // read-only
end;

{ TFileData }

constructor TFileData.Create(var FileInfo: TSearchRec);
begin
  ShortFileName := FileInfo.Name;
  Time := FileDateToDateTime (FileInfo.Time);
  Size := FileInfo.Size;
  Attr := FileInfo.Attr;
end;

procedure Register;
begin
  RegisterComponents ('Md', [TMdDirDataset]);
end;

end.

unit MdDsStream;

interface

uses
  Classes, Db, MdDsCustom;

type
  TMdDataFileHeader = record
    VersionNumber: Integer;
    RecordSize: Integer;
    RecordCount: Integer;
  end;

  TMdDataSetStream = class(TMdCustomDataSet)
  private
    procedure SetTableName(const Value: string);
  protected
    FDataFileHeader: TMdDataFileHeader;
    FDataFileHeaderSize, // file header size
    FRecordCount: Integer; // current number of records
    FStream: TStream; // the physical table
    FTableName: string; // table path and file name
    FFieldOffset: TList; // field offsets in the buffer
  protected
    // open and close
    procedure InternalPreOpen; override;
    procedure InternalAfterOpen; override;
    procedure InternalClose; override;
    procedure InternalInitFieldDefs; override;
    // edit support
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalPost; override;
    // fields
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    // custom dataset virutal methods
    function InternalRecordCount: Integer; override;
    procedure InternalLoadCurrentRecord(Buffer: PChar); override;
  public
    procedure CreateTable;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  published
    property TableName: string read FTableName write SetTableName;
  end;

procedure Register;

implementation

uses
  TypInfo, IniFiles, SysUtils;

/////////////////////////////////////////////////
////// Part I:
////// Initialization, opening, and closing
/////////////////////////////////////////////////

const
  HeaderVersion = 10;

// I: open the table/file
procedure TMdDataSetStream.InternalPreOpen;
begin
  // the size of the header
  FDataFileHeaderSize := sizeOf (TMdDataFileHeader);

  // check if the file exists
  if not FileExists (FTableName) then
    raise EMdDataSetError.Create ('Open: Table file not found');

  // create a stream for the file
  FStream := TFileStream.Create (FTableName, fmOpenReadWrite);

  // initialize local data (loading the header)
  FStream.ReadBuffer (FDataFileHeader, FDataFileHeaderSize);
  if FDataFileHeader.VersionNumber <> HeaderVersion then
    raise EMdDataSetError.Create ('Illegal File Version');
  // let's read this, double check later
  FRecordCount := FDataFileHeader.RecordCount;
end;

procedure TMdDataSetStream.InternalAfterOpen;
begin
  // check the record size
  if FDataFileHeader.RecordSize <> FRecordSize then
    raise EMdDataSetError.Create ('File record size mismatch');
  // check the number of records against the file size
  if (FDataFileHeaderSize + FRecordCount * FRecordSize) <> FStream.Size then
    raise EMdDataSetError.Create ('InternalOpen: Invalid Record Size');
end;

// I: define the fields
procedure TMdDataSetStream.InternalInitFieldDefs;
var
  IniFileName, FieldName: string;
  IniFile: TIniFile;
  nFields, I, TmpFieldOffset, nSize: Integer;
  FieldType: TFieldType;
begin
  FFieldOffset := TList.Create;
  FieldDefs.Clear;
  TmpFieldOffset := 0;
  IniFilename := ChangeFileExt(FTableName, '.ini');
  Inifile := TIniFile.Create (IniFilename);
  // protect ini file
  try
    nFields := IniFile.ReadInteger ('Fields', 'Number', 0);
    if nFields = 0 then
      raise EMdDataSetError.Create ('InitFieldsDefs: 0 fields?');
    for I := 1 to nFields do
    begin
      // create the field
      FieldType := TFieldType (GetEnumValue (
        TypeInfo (TFieldType),
        IniFile.ReadString (
          'Field' + IntToStr (I), 'Type', '')));
      FieldName := IniFile.ReadString (
        'Field' + IntToStr (I), 'Name', '');
      if FieldName = '' then
        raise EMdDataSetError.Create (
          'InitFieldsDefs: No name for field ' +
          IntToStr (I));
      nSize := IniFile.ReadInteger (
         'Field' + IntToStr (I), 'Size', 0);
      FieldDefs.Add (FieldName,
        FieldType, nSize, False);
      // save offset and compute size
      FFieldOffset.Add (Pointer (TmpFieldOffset));
      case FieldType of
        ftString:
          Inc (TmpFieldOffset, nSize + 1);
        ftBoolean, ftSmallInt, ftWord:
          Inc (TmpFieldOffset, 2);
        ftInteger, ftDate, ftTime:
          Inc (TmpFieldOffset, 4);
        ftFloat, ftCurrency, ftDateTime:
          Inc (TmpFieldOffset, 8);
      else
        raise EMdDataSetError.Create (
          'InitFieldsDefs: Unsupported field type');
      end;
    end; // for
  finally
    IniFile.Free;
  end;
  FRecordSize := TmpFieldOffset;
end;

// I: close the table/file
procedure TMdDataSetStream.InternalClose;
begin
  // if required, save updated header
  if (FDataFileHeader.RecordCount <> FRecordCount) or
    (FDataFileHeader.RecordSize = 0) then
  begin
    FDataFileHeader.RecordSize := FRecordSize;
    FDataFileHeader.RecordCount := FRecordCount;
    if Assigned (FStream) then
    begin
      FStream.Seek (0, soFromBeginning);
      FStream.WriteBuffer (
        FDataFileHeader, FDataFileHeaderSize);
    end;
  end;
  // free the internal list field offsets and the stream
  FFieldOffset.Free;
  FStream.Free;
  inherited InternalClose;
end;

// I: Create a new table/file
procedure TMdDataSetStream.CreateTable;
begin
  CheckInactive;
  InternalInitFieldDefs;

  // create the new file
  if FileExists (FTableName) then
    raise EMdDataSetError.Create ('File ' + FTableName + ' already exists');
  FStream := TFileStream.Create (FTableName,
    fmCreate or fmShareExclusive);
  try
    // save the header
    FDataFileHeader.VersionNumber := HeaderVersion;
    FDataFileHeader.RecordSize := 0; // used later
    FDataFileHeader.RecordCount := 0; // empty
    FStream.WriteBuffer (
      FDataFileHeader, FDataFileHeaderSize);
  finally
    // close the file
    FStream.Free;
  end;
end;

//////////////////////////////////////////
////// Part III:
////// Record buffers management
//////////////////////////////////////////

// III: loading of the actual data for the GetCurrent request
procedure TMdDataSetStream.InternalLoadCurrentRecord (Buffer: PChar);
begin
  FStream.Position := FDataFileHeaderSize +
    FRecordSize * FCurrentRecord;
  FStream.ReadBuffer (Buffer^, FRecordSize);
  with PMdRecInfo(Buffer + FRecordSize)^ do
  begin
    BookmarkFlag := bfCurrent;
    Bookmark := FCurrentRecord;
  end;
end;

// III: Write the current data to the file
procedure TMdDataSetStream.InternalPost;
begin
  CheckActive;
  if State = dsEdit then
  begin
    // replace data with new data
    FStream.Position := FDataFileHeaderSize +
      FRecordSize * FCurrentRecord;
    FStream.WriteBuffer (ActiveBuffer^, FRecordSize);
  end
  else
  begin
    // always append
    InternalLast;
    FStream.Seek (0, soFromEnd);
    FStream.WriteBuffer (ActiveBuffer^, FRecordSize);
    Inc (FRecordCount);
  end;
end;

// III: Add the current data to the file
procedure TMdDataSetStream.InternalAddRecord(
  Buffer: Pointer; Append: Boolean);
begin
  // always append at the end
  InternalLast;
  FStream.Seek (0, soFromEnd);
  FStream.WriteBuffer (ActiveBuffer^, FRecordSize);
  Inc (FRecordCount);
end;

//////////////////////////////////////////
////// Part IV:
////// From buffers to fields
//////////////////////////////////////////

// IV: Move data from record buffer to field
function TMdDataSetStream.GetFieldData (
  Field: TField; Buffer: Pointer): Boolean;
var
  FieldOffset: Integer;
  Ptr: PChar;
begin
  Result := False;
  if not IsEmpty and (Field.FieldNo > 0) then
  begin
    FieldOffset := Integer (
      FFieldOffset [Field.FieldNo - 1]);
    Ptr := ActiveBuffer;
    Inc (Ptr, FieldOffset);
    if Assigned (Buffer) then
      Move (Ptr^, Buffer^, Field.DataSize);
    Result := True;
    if (Field is TDateTimeField) and (PInteger(Ptr)^ = 0) then
      Result := False;
  end;
end;

// IV: Move data from field to record buffer
procedure TMdDataSetStream.SetFieldData(Field: TField; Buffer: Pointer);
var
  FieldOffset: Integer;
  Ptr: PChar;
begin
  if Field.FieldNo >= 0 then
  begin
    FieldOffset := Integer (
      FFieldOffset [Field.FieldNo - 1]);
    Ptr := ActiveBuffer;
    Inc (Ptr, FieldOffset);
    if Assigned (Buffer) then
      Move (Buffer^, Ptr^, Field.DataSize)
    else
      raise Exception.Create (
        'Very bad error in TMdDataSetStream.SetField data');
    DataEvent (deFieldChange, Longint(Field));
  end;
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdDataSetStream]);
end;

function TMdDataSetStream.InternalRecordCount: Integer;
begin
  Result := FRecordCount;
end;

procedure TMdDataSetStream.SetTableName(const Value: string);
begin
  if IsCursorOpen then
    if csDesigning in ComponentState then
      Close
    else
      raise Exception.Create ('Cannot assing an open dataset to a new file');
  FTableName := Value;
end;

end.

unit MdDbGrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, Db;

type
  TMdDbGrid = class(TDbGrid)
  private
    FLinesPerRow: Integer;
    procedure SetLinesPerRow (Value: Integer);
  protected
    procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;
      Column: TColumn; State: TGridDrawState); override;
    procedure LayoutChanged; override;
  public
    constructor Create (AOwner: TComponent); override;
  published
    property LinesPerRow: Integer
      read FLinesPerRow write SetLinesPerRow
      default 1;
  end;

procedure Register;

implementation

constructor TMdDbGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLinesPerRow := 1;
end;

procedure TMdDbGrid.LayOutChanged;
var
  PixelsPerRow, PixelsTitle, I: Integer;
begin
  inherited LayOutChanged;

  Canvas.Font := Font;
  PixelsPerRow := Canvas.TextHeight('Wg') + 3;
  if dgRowLines in Options then
      Inc (PixelsPerRow, GridLineWidth);

  Canvas.Font := TitleFont;
  PixelsTitle := Canvas.TextHeight('Wg') + 4;
  if dgRowLines in Options then
    Inc (PixelsTitle, GridLineWidth);

  // set number of rows
  RowCount := 1 + (Height - PixelsTitle) div
    (PixelsPerRow * FLinesPerRow);

  // set the height of each row
  DefaultRowHeight := PixelsPerRow * FLinesPerRow;
  RowHeights [0] := PixelsTitle;
  for I := 1 to RowCount - 1 do
    RowHeights [I] := PixelsPerRow * FLinesPerRow;
end;

procedure TMdDbGrid.DrawColumnCell(const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  Bmp: TBitmap;
  OutRect: TRect;
begin
  if FLinesPerRow = 1 then
    inherited DrawColumnCell(Rect, DataCol, Column, State)
  else
  begin
    // clear area
    Canvas.FillRect (Rect);
    // copy the rectangle
    OutRect := Rect;
    // restrict output
    InflateRect (OutRect, -2, -2);
    // output field data
    if Column.Field is TGraphicField then
    begin
      Bmp := TBitmap.Create;
      try
        Bmp.Assign (Column.Field);
        Canvas.StretchDraw (OutRect, Bmp);
      finally
        Bmp.Free;
      end;
    end
    else if Column.Field is TMemoField then
    begin
      DrawText (Canvas.Handle,
        PChar (Column.Field.AsString),
        Length (Column.Field.AsString),
        OutRect, dt_WordBreak or dt_NoPrefix)
    end
    else // draw single line vertically centered
      DrawText (Canvas.Handle,
        PChar (Column.Field.DisplayText),
        Length (Column.Field.DisplayText),
        OutRect, dt_vcenter or dt_SingleLine or dt_NoPrefix);
  end;
end;

procedure TMdDbGrid.SetLinesPerRow(Value: Integer);
begin
  if Value <> FLinesPerRow then
  begin
    FLinesPerRow := Value;
    LayoutChanged;
  end;
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdDbGrid]);
end;

end.

unit MdRView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DB, StdCtrls;

type
  TMdRecordView = class(TCustomGrid)
  private
    // data-aware support
    FDataLink: TDataLink;
    function GetDataSource: TDataSource;
    procedure SetDataSource (Value: TDataSource);
  protected
    // redefined TCustomGrid methods
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
      AState: TGridDrawState); override;
    procedure ColWidthsChanged; override;
    procedure RowHeightsChanged; override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds (ALeft, ATop, AWidth,
      AHeight: Integer); override;
    // parent properties
    property Canvas;
    property Col;
    property ColWidths;
    property EditorMode;
    property GridHeight;
    property GridWidth;
    property LeftCol;
    property Selection;
    property Row;
    property RowHeights;
    property TabStops;
    property TopRow;
  published
    // data-aware properties
    property DataSource: TDataSource
      read GetDataSource write SetDataSource;
    // parent properties
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DefaultColWidth;
    property DefaultRowHeight;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FixedColor;
    property Font;
    property GridLineWidth;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property VisibleColCount;
    property VisibleRowCount;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

procedure Register;

implementation

////// Custom DataLink //////

type
  TMdRecordLink = class (TDataLink)
  private
    RView: TMdRecordView;
  public
    constructor Create (View: TMdRecordView);
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
  end;

constructor TMdRecordLink.Create (View: TMdRecordView);
begin
  inherited Create;
  RView := View;
end;

procedure TMdRecordLink.ActiveChanged;
var
  I: Integer;
begin
  // set number of rows
  if Assigned (DataSet) then
  begin
    RView.RowCount := DataSet.FieldCount;
    // double the height of memo and graphics
    for I := 0 to DataSet.FieldCount - 1 do
      if DataSet.Fields [I] is TBlobField then
        RView.RowHeights [I] := RView.DefaultRowHeight * 2;
    // repaint all...
    RView.Invalidate;
  end;
end;

procedure TMdRecordLink.RecordChanged;
begin
  inherited;
  // repaint all...
  RView.Invalidate;
end;

////// data-aware component //////

constructor TMdRecordView.Create (AOwner: TComponent);
begin
  FDataLink := TMdRecordLink.Create (self);
  inherited Create (AOwner);
  // set numbers of cells and fixed cells
  RowCount := 2; // default
  ColCount := 2;
  FixedCols := 1;
  FixedRows := 0;
  {grid options -- choose among:
    goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine,
    goRangeSelect, goDrawFocusSelected, goRowSizing, goColSizing,
    goRowMoving, goColMoving, goEditing, goTabs, goRowSelect,
    goAlwaysShowEditor, goThumbTracking}
  Options := [goFixedVertLine, goFixedHorzLine,
    goVertLine, goHorzLine, goRowSizing, goColSizing];
  DefaultDrawing := False;
  ScrollBars := ssVertical;
  // FSaveCellExtents := False;
end;

destructor TMdRecordView.Destroy;
begin
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

procedure TMdRecordView.SetBounds (ALeft, ATop,
  AWidth, AHeight: Integer);
begin
  inherited;
  ColWidths [1] := Width - ColWidths [0] -
    GridLineWidth * 3 -
    GetSystemMetrics (sm_CXVScroll)
    - 2; // border
end;

procedure TMdRecordView.ColWidthsChanged;
begin
  ColWidths [1] := Width - ColWidths [0] -
    GridLineWidth * 3 -
    GetSystemMetrics (sm_CXVScroll)
    - 2; // border
end;

// grid drawing
procedure TMdRecordView.DrawCell(ACol, ARow: Longint;
  ARect: TRect; AState: TGridDrawState);
var
  Text: string;
  CurrField: TField;
  Bmp: TBitmap;
begin
  CurrField := nil;
  Text := '[]'; // default
  // paint background
  if (ACol = 0) then
    Canvas.Brush.Color := FixedColor
  else
    Canvas.Brush.Color := Color;
  Canvas.FillRect (ARect);
  // leave small border
  InflateRect (ARect, -2, -2);
  if (FDataLink.DataSource <> nil) and
    FDataLink.Active then
  begin
    CurrField := FDataLink.DataSet.Fields[ARow];
    if ACol = 0 then
      Text := CurrField.DisplayName
    else if CurrField is TMemoField then
      Text := TMemoField (CurrField).AsString
    else
      Text := CurrField.DisplayText;
  end;
  if (ACol = 1) and (CurrField is TGraphicField) then
  begin
    Bmp := TBitmap.Create;
    try
      Bmp.Assign (CurrField);
      Canvas.StretchDraw (ARect, Bmp);
    finally
      Bmp.Free;
    end;
  end
  else if (ACol = 1) and (CurrField is TMemoField) then
  begin
    DrawText (Canvas.Handle,
      PChar (Text), Length (Text),
      ARect, dt_WordBreak or dt_NoPrefix)
  end
  else // draw single line vertically centered
    DrawText (Canvas.Handle,
      PChar (Text), Length (Text), ARect,
      dt_vcenter or dt_SingleLine or dt_NoPrefix);
  if gdFocused in AState then
    Canvas.DrawFocusRect (ARect);
end;

// data-aware support
function TMdRecordView.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TMdRecordView.SetDataSource (Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdRecordView]);
end;

procedure TMdRecordView.RowHeightsChanged;
begin
  inherited;
  // refresh actual values
  (FDataLink as TMdRecordLink).ActiveChanged;
end;

end.

unit MdRepPr;

   interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms,
  ComCtrls, DB, DBCtrls;

type
  TMdDbRepProgress = class(TProgressBar)
  private
    FDataLink: TFieldDataLink;
    FPaintControl: TPaintControl;
    function GetDataField: string;
    procedure SetDataField (Value: string);
    function GetDataSource: TDataSource;
    procedure SetDataSource (Value: TDataSource);
    function GetField: TField;
    // DbCtrlGrid support
    procedure CmGetDataLink (var Msg: TMessage);
      message cm_GetDataLink;
    procedure WmPaint (var Msg: TWmPaint);
      message wm_Paint;
    function GetPos: Integer;
  protected
    procedure WndProc(var Message: TMessage); override;
    // data link event handler
    procedure DataChange (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    property Field: TField read GetField;
  published
    property DataField: string
      read GetDataField write SetDataField;
    property DataSource: TDataSource
      read GetDataSource write SetDataSource;
  end;

procedure Register;

implementation

uses
  Dialogs, CommCtrl, DbCGrids;

constructor TMdDbRepProgress.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := self;
  FDataLink.OnDataChange := DataChange;
  // enable use in DBCtrlGrid
  ControlStyle := ControlStyle + [csReplicatable];
  FPaintControl := TPaintControl.Create(
    self, PROGRESS_CLASS);
end;

destructor TMdDbRepProgress.Destroy;
begin
  FDataLink.Free;
  FDataLink := nil;
  FPaintControl.Free;
  inherited Destroy;
end;

function TMdDbRepProgress.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TMdDbRepProgress.SetDataField (Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TMdDbRepProgress.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TMdDbRepProgress.SetDataSource (Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;

function TMdDbRepProgress.GetField: TField;
begin
  Result := FDataLink.Field;
end;

// data link event handler
procedure TMdDbRepProgress.DataChange (Sender: TObject);
begin
  SendMessage(Handle, Wm_SetRedraw, 0, 0);
  Position := GetPos;
  SendMessage(Handle, Wm_SetRedraw, 1, 0);
  if HandleAllocated then
    RedrawWindow (Handle, nil, 0,
      RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
end;

function TMdDbRepProgress.GetPos;
begin
  if (FDataLink.Field <> nil) and
      (FDataLink.Field is TNumericField) then
    Result := FDataLink.Field.AsInteger
  else
    Result := Min;
end;

// DBCtrlGrid support methods

procedure TMdDbRepProgress.CmGetDataLink (var Msg: TMessage);
begin
  Msg.Result := Integer (fDataLink);
end;

procedure TMdDbRepProgress.WmPaint (var Msg: TWmPaint);
begin
  if not (csPaintCopy in ControlState) then
    inherited
  else
  begin
    SendMessage(FPaintControl.Handle, Wm_SetRedraw, 0, 0);
    SendMessage(FPaintControl.Handle, PBM_SETRANGE32, Min, Max);
    SendMessage(FPaintControl.Handle, PBM_SETPOS, GetPos, 0);
    SendMessage(FPaintControl.Handle, PBM_SETSTEP, Step, 0);
    SendMessage(FPaintControl.Handle, Wm_SetRedraw, 1, 0);
       SendMessage(FPaintControl.Handle,
      wm_Paint, Msg.DC, 0);
  end;
end;

procedure TMdDbRepProgress.WndProc(var Message: TMessage);
begin
  with Message do
    if (Msg = WM_CREATE) or
        (Msg = WM_WINDOWPOSCHANGED) then
      FPaintControl.DestroyHandle;
  inherited;
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdDbRepProgress]);
end;

end.

unit MdProgr;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms,
  ComCtrls, DB, DBCtrls;

type
  TMdDbProgress = class(TProgressBar)
  private
    FDataLink: TFieldDataLink;
    function GetDataField: string;
    procedure SetDataField (Value: string);
    function GetDataSource: TDataSource;
    procedure SetDataSource (Value: TDataSource);
    function GetField: TField;
  protected
    // data link event handler
    procedure DataChange (Sender: TObject);
    // useless
    {procedure Notification (AComponent: TComponent;
      Operation: TOperation); override;}
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    property Field: TField read GetField;
  published
    property DataField: string
      read GetDataField write SetDataField;
    property DataSource: TDataSource
      read GetDataSource write SetDataSource;
  end;

procedure Register;

implementation

uses
  Dialogs, CommCtrl, DbCGrids;

constructor TMdDbProgress.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := self;
  FDataLink.OnDataChange := DataChange;
end;

destructor TMdDbProgress.Destroy;
begin
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

function TMdDbProgress.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TMdDbProgress.SetDataField (Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TMdDbProgress.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TMdDbProgress.SetDataSource (Value: TDataSource);
begin
  FDataLink.DataSource := Value;
  // useless
  {if Value <> nil then
    Value.FreeNotification (Value);}
end;

function TMdDbProgress.GetField: TField;
begin
  Result := FDataLink.Field;
end;

// data link event handler
procedure TMdDbProgress.DataChange (Sender: TObject);
begin
  if (FDataLink.Field <> nil) and
      (FDataLink.Field is TNumericField) then
    Position := FDataLink.Field.AsInteger
  else
    Position := Min;
end;

// useless
{procedure TMdDbProgress.Notification (AComponent: TComponent;
  Operation: Toperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = FDataLink.DataSource) then
  begin
    FDataLink.DataSource := nil;
    ShowMessage ('Data source set to nil');
  end
  else if (Operation = opRemove) and (FDataLink <> nil) and
    (FDataLink.DataSource = nil) then
  begin
    ShowMessage ('Data source was already nil');
  end;
end;}

procedure Register;
begin
  RegisterComponents('Md', [TMdDbProgress]);
end;

end.

unit MdTrack;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, DB, DBCtrls;

type
  TMdDbTrack = class(TTrackBar)
  private
    FDataLink: TFieldDataLink;
    function GetDataField: string;
    procedure SetDataField (Value: string);
    function GetDataSource: TDataSource;
    procedure SetDataSource (Value: TDataSource);
    function GetField: TField;
    procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
  protected
    // data link event handlers
    procedure DataChange (Sender: TObject);
    procedure UpdateData (Sender: TObject);
    procedure ActiveChange (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    property Field: TField read GetField;
  published
    property DataField: string
      read GetDataField write SetDataField;
    property DataSource: TDataSource
      read GetDataSource write SetDataSource;
  end;

procedure Register;

implementation

constructor TMdDbTrack.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := self;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnUpdateData := UpdateData;
  FDataLink.OnActiveChange := ActiveChange;
  Enabled := False;
end;

destructor TMdDbTrack.Destroy;
begin
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

function TMdDbTrack.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TMdDbTrack.SetDataField (Value: string);
begin
  try
    FDataLink.FieldName := Value;
  finally
    Enabled := FDataLink.Active and
      (FDataLink.Field <> nil) and
      not FDataLink.Field.ReadOnly;
  end;
end;

function TMdDbTrack.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TMdDbTrack.SetDataSource (Value: TDataSource);
begin
  FDataLink.DataSource := Value;
  Enabled := FDataLink.Active and
    (FDataLink.Field <> nil) and
    not FDataLink.Field.ReadOnly;
end;

function TMdDbTrack.GetField: TField;
begin
  Result := FDataLink.Field;
end;

// data link event handler
procedure TMdDbTrack.DataChange (Sender: TObject);
begin
  if (FDataLink.Field <> nil) and
      (FDataLink.Field is TNumericField) then
    Position := FDataLink.Field.AsInteger
  else
    Position := Min;
end;

procedure TMdDbTrack.ActiveChange (Sender: TObject);
begin
  Enabled := FDataLink.Active and
    (FDataLink.Field <> nil) and
    not FDataLink.Field.ReadOnly;
end;

// update
procedure TMdDbTrack.CNHScroll(var Message: TWMHScroll);
begin
  // edit mode
  FDataLink.Edit;
  // update data
  inherited;
  // let the system know
  FDataLink.Modified;
end;

procedure TMdDbTrack.CNVScroll(var Message: TWMVScroll);
begin
  // edit mode
  FDataLink.Edit;
  // update data
  inherited;
  // let the system know
  FDataLink.Modified;
end;

procedure TMdDbTrack.CMExit(var Message: TCMExit);
begin
  try
    FDataLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  inherited;
end;

procedure TMdDbTrack.UpdateData (Sender: TObject);
begin
  if (FDataLink.Field <> nil) and
      (FDataLink.Field is TNumericField) then
    FDataLink.Field.AsInteger := Position;
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdDbTrack]);
end;

end.