Статьи по Delphi (005)…

Как определить изменение фокуса строки в TDBGrid.

procedure Form1.DSrc1DataChange(Sender: TObject; Field: TField);

Поля TTable могут использоваться для сравнения текущих выбранных строк полей (ключ) с вашими требованиями. С той же целью может быть использовано и свойство TDBGrid Fields. Для примера:

if tbl1.Fields[0].AsString = 'BlaBlaBla' then ...

Или.

if dbGrid1.Fields[I].IsNull then ... 

procedure Form1.dbGrid1DrawDataCell(Sender: TObject; Rect: TRect;
Field: TField; State: TGridDrawState);

Чтобы иметь доступ к индексу строки или колонки выбранной ячейки, вы должны унаследовать ваш класс от TCustomGrid и опубликать свойства времени выполнения Row и Col (текущие строка и колонка сетки, не таблицы!!):

type
TSampleDBGrid = class(TCustomGrid)
public
property Col;
property Row;
end;

В соответствующей процедуре или обработчике события осуществите приведение типа:

var
G: TSampleDBGrid;
begin
G := TSampleDBGrid(myDBGrid1);
if G.Row = I then ...
if G.Col = J then ...

Дело в том, что TDBGrid является потомком TCustomGrid, который имеет несколько свойств, содержащих координаты сетки, но это не опубликовано в TDBGrid.

...из чего я могу заключить, что вы должны это сделать программным путем. Подразумеваем, что сетка уже существует, и у вас есть доступ к основной таблице TTable:

grid.colcount := dbGrid.fieldcount;
table.first;
row := 0;
while not table.eof do begin
grid.rowcount := row + 1;
for i := 0 to grid.colcount-1 do
grid.cells[i,row] := dbGrid.fields[i].asString;
table.next;
inc (row);
end;

Посмотрите на следующий код, он может вам помочь. Он берет у элемента управления свойсто 'Name' и помещает его в свойство 'Caption' метки.

unit Unit1;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Edit2MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
  close;
end;
procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Label1.Caption := TEdit(Sender).Name;
end;
procedure TForm1.Edit2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Label1.Caption := TEdit(Sender).Name;
end;
end.

Определить номер строки в TDBGrid.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
 I did not found property to know the rownumber of a TDBGrid, 
 so I will try this in the OnDrawColumnCell of a DBGrid: 
}
 procedure TformX.DBGridXDrawColumnCell(Sender: TObject; const
   Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
 var
   RowNo : Integer;
 begin
   RowNo := Rect.Bottom div TStringGrid(DBGridX).DefaultRowHeight
   //so, RowNo has the Row to be draw in the moment 
  ...
 end;

DBGrid - сохранение конфигурации.

Нижеописанный код создает, сохраняет и загружает конфигурационный файл и изменяет размеры столбцов таблицы DBGRID.

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DBGrids, Db, DBTables, StdCtrls, IniFiles;
...
procedure TMainForm.NewIni(const NomeIni: string);
var
  F: System.Text;
  i: Byte;
begin
  System.Assign(F, NomeIni);
  System.ReWrite(F);
  System.WriteLn(F, '[Campi_Ordine]');
  for i:=1 to Table1.FieldCount do
    System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].FieldName);
  System.WriteLn(F, '');
  System.WriteLn(F, '[Campi_Size]');
  for i:=1 to Table1.FieldCount do
    System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].DisplayWidth);
  System.Close(F);
end;
procedure TMainForm.SaveIni(const FN: string);
var
  Ini: TIniFile;
  i: Integer;
  S : string;
begin
  NewIni(FN);
  Ini := TIniFile.Create(FN);
  with Ini do begin
    for i:=1 to Table1.FieldCount do
    begin
      S:= Table1.Fields[i-1].FieldName;
      WriteString('Campi_Ordine', 'Campo'+IntToStr(i),
      Table1.Fields[i-1].FieldName);
      WriteInteger('Campi_Size', 'Campo'+IntToStr(i),
      Table1.Fields[i-1].DisplayWidth);
    end;
  end;
  Ini.Free;
end;
procedure TMainForm.LoadIni(const FN: string);
var
  Ini: TIniFile;
  i: Integer;
  j: Longint;
  S: string;
  function MyReadInteger(const Section, Ident: string): Longint;
  begin
    result := Ini.ReadInteger(Section, Ident, -1);
    if result=-1 then
      raise Exception.Create('Errore nel file di configurazione.');
  end;
  function MyReadString(const Section, Ident: string): string;
  begin
    result := Ini.ReadString(Section, Ident, '');
    if result='' then
      raise Exception.Create('Errore nel file di configurazione.');
  end;
begin
  Ini := TIniFile.Create(FN);
  try
    with Ini do
    begin
      for i:=1 to Table1.FieldCount do
      begin
        S:= MyReadString('Campi_Ordine', 'Campo'+IntToStr(i));
        j:= MyReadInteger('Campi_Size', 'Campo'+IntToStr(i));
        Table1.FieldByName(S).index := i-1;
        Table1.FieldByName(S).DisplayWidth := j;
      end;
    end;
  finally
    Ini.Free;
  end;
end;

DBGrid - выбранные строки.

Существует одно свойство, не упомянутое в файлах помощи (оплошность, господа программисты из Borland), имеющее имя SelectedRows, и вот как его можно использовать:

procedure TfrmGrid.Button1Click(Sender: TObject);
var
  i: integer;
begin
  For i := 0 to DBGrid1.SelectedRows.Count - 1 do
  begin
    Table1.GoToBookmark(TBookmark(DBGrid1.SelectedRows[i]));
    Table1.Delete;
  end;
end;

Выделить все строки в DBGrid.

function GridSelectAll(Grid: TDBGrid): Longint;
begin
  Result := 0;
  Grid.SelectedRows.Clear;
  with Grid.Datasource.DataSet do
  begin
    First;
    DisableControls;
    try
      while not EOF do
      begin
        Grid.SelectedRows.CurrentRowSelected := True;
        inc(Result);
        Next;
      end;
    finally
      EnableControls;
    end;
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  GridSelectAll(DBGrid1);
end;

Как выделить окошко DBGrid другим цветом.

Оформил: DeeCo

procedure TForm1.DBGridDrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if gdFocused in State then
    with (Sender as TDBGrid).Canvas do
    begin
      Brush.Color := clRed;
      FillRect(Rect);
      TextOut(Rect.Left, Rect.Top, Field.AsString);
    end;
end;

Решение проблемы передачи фокуса TDBGrid.

Очевидно, DBGrid имеет некоторые проблемы с управлением фокусом, если он находится на дочерней MDI-форме. Эта проблема решена в приведенном ниже наследнике TDBGrid, в котором обрабатываются мышиные сообщения и выясняется когда фокус должен быть передан сетке. Наследник создан в виде компонента, который легко устанавливается в Палитру Компонентов. Примечание: код адаптирован для всех версий Delphi. Проблемы могут быть в Delphi 2 и 3, если вы забудете заменить устаревшие в этих версиях модули "winprocs" и "wintypes" на "windows.".

unit FixedDBGrid;
interface
uses
  Winprocs, wintypes, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, Grids, DBGrids;
type
  TFixedDBGrid = class(TDBGrid)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    procedure WMRButtonDown(var Message: TWMRButtonDown); message
      WM_RBUTTONDOWN;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message
      WM_LBUTTONDOWN;
  published
    { Published declarations }
  end;
procedure Register;
implementation
procedure TFixedDBGrid.WMRButtonDown(var Message: TWMRButtonDown);
begin
  winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
  inherited;
end;
procedure TFixedDBGrid.WMLButtonDown(var Message: TWMLButtonDown);
begin
  winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
  inherited;
end;
procedure Register;
begin
  RegisterComponents('Samples', [TFixedDBGrid]);
end;
end.

Сортировка колонок в DBGrid.

Сделаем так, чтобы компонент THeaderControl выглядел похожим на заголовок компонента DBGrid. Произведем необходимые манипулиции в момент создания формы. Дважды щелкните на событии OnCreate формы и введите следующий код:

procedure TForm1.FormCreate(Sender: TObject);
var
  TheCap: string;
  TheWidth, a: Integer;
begin
  DBGrid1.Options := DBGrid1.Options - [dgTitles];
  HeaderControl1.Sections.Add;
  HeaderControl1.Sections.Items[0].Width := 12;
  Table1.Exclusive := True;
  Table1.Active := True;
  for a := 1 to DBGrid1.Columns.Count do
  begin
    with DBGrid1.Columns.Items[a - 1] do
    begin
      TheCap := Title.Caption;
      TheWidth := Width;
    end;
    with HeaderControl1.Sections do
    begin
      Add;
      Items[a].Text := TheCap;
      Items[a].Width := TheWidth + 1;
      Items[a].MinWidth := TheWidth + 1;
      Items[a].MaxWidth := TheWidth + 1;
    end;
    try
      Table1.AddIndex(TheCap, TheCap, []);
    except
      HeaderControl1.Sections.Items[a].AllowClick := False;
    end;
  end;
  Table1.Active := False;
  Table1.Exclusive := False;
  Table1.Active := True;
end;

Последний шаг. При щелчке на HeaderControl нам необходимо включить правильный индекс таблицы. Создадим обработчик события OnSectionClick компонента HeaderControl как показано ниже:

procedure TForm1.HeaderControl1SectionClick(
HeaderControl: THeaderControl; Section: THeaderSection);
begin
  Table1.IndexName := Section.Text;
end;

Это улучшает гибкость. Изменения указаны наклонным курсивом.

procedure TfrmDoc.FormCreate(Sender: TObject);
var
  TheCap: string;
  TheFn: string;
  TheWidth: Integer;
  a: Integer;
begin
  Dbgrid1.Options := DBGrid1.Options - [DGTitles];
  Headercontrol1.sections.Add;
  Headercontrol1.Sections.Items[0].Width := 12;
  for a := 1 to DBGRID1.Columns.Count do
  begin
    with DBGrid1.Columns.Items[a - 1] do
    begin
      TheFn := FieldName;
      TheCap := Title.Caption;
      TheWidth := Width;
    end;
    with Headercontrol1.Sections do
    begin
      Add;
      Items[a].Text := TheCap;
      Items[a].Width := TheWidth + 1;
      Items[a].MinWidth := TheWidth + 1;
      Items[a].MaxWidth := TheWidth + 1;
    end; (* WITH Headercontrol1.Sections *)
    try (* except *)
      { Используем индексы с тем же именем, что и имя поля }
      (DataSource1.Dataset as TTable).IndexName := TheFn;
        { Пробуем задать имя индекса }
    except
      HeaderControl1.Sections.Items[a].AllowClick := False; { Индекс недоступен }
    end; (* EXCEPT *)
  end; (* FOR *)
end; (* PROCEDURE *)

Используйте свойство FieldName компонента DBGrid для задания индекса с тем же именем, что и имя поля.

procedure TfrmDoc.HeaderControl1SectionClick(HeaderControl:
THeaderControl; Section: THeaderSection);
begin
  (DataSource1.Dataset as TTable).IndexName :=
  DBGrid1.Columns.Items[ Section.Index - 1 ].FieldName;
end;

Копирование информации из DBGrid-а в Clipboard.

Простая процедура копирования информации из DBGrid-а в Clipboard может существенно облегчить жизнь при реализации требований экспорта выборок данных во внешние приемники. Удобнее вызов "прицепить" к контекстному меню грида.

unit UnGridToClb;
interface
uses
  Windows, SysUtils, Classes, Dialogs,
  Grids, DBGrids, Db, DBTables, ClipBrd;
procedure CopyGRDToClb(dbg: TDBGrid);
// Копирует DBGrid в буфер обмена,
// после чего данные отлично переносятся
// как в простой текстовый редактор, так и в Excell
implementation
procedure CopyGRDToClb(dbg: TDBGrid);
var
  bm: TBookMark;
  pch, pch1: PChar;
  s, s2: string;
  i, j: integer;
begin
  s := '';
  for j := 0 to dbg.Columns.Count - 1 do
    s := s + dbg.Columns.Items[j].Title.Caption + #9;
  s := s + #13 + #10;
  if not dbg.DataSource.DataSet.active then
  begin
    ShowMessage('Нет выборки!!!');
    Exit;
  end;
  try
    dbg.Visible := False; //Делаем грид невидимым, чтобы не тратилось время
    //на его перерисовку при прокрутке DataSet - просто и
    //эффективно
    bm := dbg.DataSource.DataSet.GetBookmark; // для того чтобы не
    // потерять текущую запись
    dbg.DataSource.DataSet.First;
    while not dbg.DataSource.DataSet.EOF do
    begin
      s2 := '';
      for j := 0 to dbg.Columns.Count - 1 do
      begin
        s2 := s2 + dbg.Columns.Items[j].Field.AsString + #9;
      end;
      s := s + s2 + #13 + #10;
      dbg.DataSource.DataSet.Next;
    end;
    //Переключаем клавиатуру "в русский режим",
    //иначе - проблемы с кодировкой
    GetMem(pch, 100);
    GetMem(pch1, 100);
    GetKeyboardLayoutName(pch);
    StrCopy(pch1, pch);
    while pch <> '00000419' do
    begin
      ActivateKeyboardLayout(HKL_NEXT, 0);
      GetKeyboardLayoutName(pch);
      if strComp(pch, pch1) = 0 then
        //Круг замкнулся - нет такого языка '00000419'
        StrCopy(pch, '00000419');
    end;
    clipboard.AsText := s; //Данные - в буфер!!!
    //Возвращаем режим клавиатуры
    while strComp(pch, pch1) <> 0 do
    begin
      ActivateKeyboardLayout(HKL_NEXT, 0);
      GetKeyboardLayoutName(pch);
    end;
    FreeMem(pch);
    FreeMem(pch1);
    dbg.DataSource.DataSet.GotoBookmark(bm);
    //ShowMessage('Данные успешно скопированы в буфер обмена.');
  finally
    dbg.Visible := True;
  end;
end;
end.

Как из DBGrid перенести данные в существующий Excel файл.

//Если не обезательно из DBGrid-а... то вот пример из Query ...
// Если есть вопросы то ¹ ACQ 134087719
// имя файла шаблона и откуда (можно TTable)
Procedure SendtoExcel(ShFile: String; Querys: TQuery);
Var
   ExcelApp, Workbook, Range, Cell1, Cell2, ArrayData: Variant;
   BeginCol, BeginRow, j: integer;
   RowCount, ColCount: Integer;
Begin
   BeginCol := 1;
   BeginRow := 3;
 // Размеры выводимого массива данных
   RowCount := Querys.RecordCount;
   ColCount := Querys.FieldDefs.Count;
 // Создание Excel
   ExcelApp := CreateOleObject('Excel.Application');
 // Отключаем реакцию Excel на события, чтобы ускорить вывод информации
   ExcelApp.Application.EnableEvents := false;
 //  Создаем Книгу (Workbook)
 //  Если заполняем шаблон, то
   Workbook := ExcelApp.WorkBooks.Add(ShFile);
   ArrayData := VarArrayCreate([1, RowCount, 1, ColCount], varVariant);
 // Заполняем массив
   Querys.DisableControls;
   Querys.First;
   While Not Querys.eof Do
   Begin
       For J := 1 To Querys.FieldDefs.Count Do
       Begin
           ArrayData[Querys.RecNo, J] :=
            Querys.FieldbyName(Querys.FieldDefs.Items[j - 1].DisplayName).value;
       End;
       Querys.Next;
   End;
   Querys.EnableControls;
//     Левая верхняя ячейка области, в которую будем выводить данные
   Cell1 := WorkBook.WorkSheets[1].Cells[BeginRow, BeginCol];
 // Правая нижняя ячейка области, в которую будем выводить данные
   Cell2 := WorkBook.WorkSheets[1].Cells[BeginRow + RowCount - 1,
    BeginCol + ColCount - 1];
 // Область, в которую будем выводить данные
   Range := WorkBook.WorkSheets[1].Range[Cell1, Cell2];
 // А вот и сам вывод данных
 // Намного быстрее поячеечного присвоения
   Range.Value := ArrayData;
 // Делаем Excel видимым
   ExcelApp.Visible := True;
End;

Экспорт из TDBGrid в Excel без OLE.

Автор: http://www.swissdelphicenter.ch

{
  Exporting a DBGrid to excel without OLE
  I develop software and about 95% of my work deals with databases.
  I enjoied the advantages of using Microsoft Excel in my projects
  in order to make reports but recently I decided to convert myself
  to the free OpenOffice suite.
  I faced with the problem of exporting data to Excel without having
  Office installed on my computer.
  The first solution was to create directly an Excel format compatible file:
  this solution is about 50 times faster than the OLE solution but there
  is a problem: the output file is not compatible with OpenOffice.
  I wanted a solution which was compatible with each "DataSet";
  at the same time I wanted to export only the dataset data present in
  a DBGrid and not all the "DataSet".
  Finally I obtained this solution which satisfied my requirements.
  I hope that it will be usefull for you too.
  First of all you must import the ADOX type library
  which will be used to create the Excel file and its
  internal structure: in the Delphi IDE:
  1)Project->Import Type Library:
  2)Select "Microsoft ADO Ext. for DDL and Security"
  3)Uncheck "Generate component wrapper" at the bottom
  4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in
    (TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog)
    in order to avoid conflicts with the already present TTable component.
  5)Select the Unit dir name and press "Create Unit".
    It will be created a file named AOX_TLB.
    Include ADOX_TLB in the "uses" directive inside the file in which you want
    to use ADOX functionality.
  That is all. Let's go now with the implementation:
 }
unit DBGridExportToExcel;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;
type
  TScrollEvents = class
    BeforeScroll_Event: TDataSetNotifyEvent;
    AfterScroll_Event: TDataSetNotifyEvent;
    AutoCalcFields_Property: Boolean;
  end;
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents:
  TScrollEvents);
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName:
  string);
implementation
//Support procedures: I made that in order to increase speed in
//the process of scanning large amounts
//of records in a dataset
//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
//"AfterScroll" events and the "AutoCalcFields" property.
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents:
  TScrollEvents);
begin
  with DataSet do
  begin
    DisableControls;
    ScrollEvents := TScrollEvents.Create();
    with ScrollEvents do
    begin
      BeforeScroll_Event := BeforeScroll;
      AfterScroll_Event := AfterScroll;
      AutoCalcFields_Property := AutoCalcFields;
      BeforeScroll := nil;
      AfterScroll := nil;
      AutoCalcFields := False;
    end;
  end;
end;
//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
  with DataSet do
  begin
    EnableControls;
    with ScrollEvents do
    begin
      BeforeScroll := BeforeScroll_Event;
      AfterScroll := AfterScroll_Event;
      AutoCalcFields := AutoCalcFields_Property;
    end;
  end;
end;
//This is the procedure which make the work:
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName:
  string);
var
  cat: _Catalog;
  tbl: _Table;
  col: _Column;
  i: integer;
  ADOConnection: TADOConnection;
  ADOQuery: TADOQuery;
  ScrollEvents: TScrollEvents;
  SavePlace: TBookmark;
begin
  //
  //WorkBook creation (database)
  cat := CoCatalog.Create;
  cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' +
    FileName + ';Extended Properties=Excel 8.0');
  //WorkSheet creation (table)
  tbl := CoTable.Create;
  tbl.Set_Name(SheetName);
  //Columns creation (fields)
  DBGrid.DataSource.DataSet.First;
  with DBGrid.Columns do
  begin
    for i := 0 to Count - 1 do
      if Items[i].Visible then
      begin
        col := nil;
        col := CoColumn.Create;
        with col do
        begin
          Set_Name(Items[i].Title.Caption);
          Set_Type_(adVarWChar);
        end;
        //add column to table
        tbl.Columns.Append(col, adVarWChar, 20);
      end;
  end;
  //add table to database
  cat.Tables.Append(tbl);
  col := nil;
  tbl := nil;
  cat := nil;
  //exporting
  ADOConnection := TADOConnection.Create(nil);
  ADOConnection.LoginPrompt := False;
  ADOConnection.ConnectionString :=
    'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName +
    ';Extended Properties=Excel 8.0';
  ADOQuery := TADOQuery.Create(nil);
  ADOQuery.Connection := ADOConnection;
  ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
  ADOQuery.Open;
  DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
  SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
  try
    with DBGrid.DataSource.DataSet do
    begin
      First;
      while not Eof do
      begin
        ADOQuery.Append;
        with DBGrid.Columns do
        begin
          ADOQuery.Edit;
          for i := 0 to Count - 1 do
            if Items[i].Visible then
            begin
              ADOQuery.FieldByName(Items[i].Title.Caption).AsString :=
                FieldByName(Items[i].FieldName).AsString;
            end;
          ADOQuery.Post;
        end;
        Next;
      end;
    end;
  finally
    DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);
    DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);
    EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
    ADOQuery.Close;
    ADOConnection.Close;
    ADOQuery.Free;
    ADOConnection.Free;
  end;
end;
end.

Экспортировать DBGrid в HTML.

type
 TGridToHTMLOption = (ghWithHeaders);
 TGridToHTMLOptions = set of TGridToHTMLOption;
function DBGridToHTML(Grid : TDBGrid;
  ExportOptions: TGridToHTMLOptions): String;
const
  HTMLStart =
   '< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN" > '#13
+
   '< HTML> '#13 +
   '< HEAD> < META http-equiv=Content-Type content=" text/html;
charset=windows-1251" > '#13 +
   '< STYLE> '#13 +
   'BODY {'#13 +
   ' BACKGROUND: white;'#13 +
   ' COLOR: black;'#13 +
   ' FONT-FAMILY: arial;'#13 +
   ' FONT-SIZE: 8pt;'#13 +
   ' VERTICAL-ALIGN: top'#13 +
   '}'#13 +
   'TABLE {'#13 +
   ' BACKGROUND: white;'#13 +
   ' BORDER-BOTTOM: silver 0px solid;'#13 +
   ' BORDER-LEFT: silver 1px solid;'#13 +
   ' BORDER-RIGHT: silver 0px solid;'#13 +
   ' BORDER-TOP: silver 1px solid;'#13 +
   ' FONT-FAMILY: arial;'#13 +
   ' FONT-SIZE: 8pt;'#13 +
   ' FONT-WEIGHT: normal;'#13 +
   '}'#13 +
   'TD {'#13 +
   ' BORDER-BOTTOM: silver 1px solid;'#13 +
   ' BORDER-LEFT: silver 0px solid;'#13 +
   ' BORDER-RIGHT: silver 1px solid;'#13 +
   ' BORDER-TOP: silver 0px solid;'#13 +
   ' VERTICAL-ALIGN: top;'#13 +
   ' TEXT-ALIGN: left;'#13 +
   '}'#13 +
   'TD.grid {'#13 +
   ' TEXT-ALIGN: left;'#13 +
   '}'#13 +
   'TD.gridr {'#13 +
   ' TEXT-ALIGN: right;'#13 +
   '}'#13 +
   'TD.gridc {'#13 +
   ' TEXT-ALIGN: center;'#13 +
   '}'#13 +
   'TH {'#13 +
   ' BACKGROUND: silver;'#13 +
   ' BORDER-BOTTOM: gray 1px solid;'#13 +
   ' BORDER-LEFT: gray 0px solid;'#13 +
   ' BORDER-RIGHT: gray 1px solid;'#13 +
   ' BORDER-TOP: gray 0px solid;'#13 +
   ' FONT-WEIGHT: bold;'#13 +
   '}'#13 +
   'TH.grid {'#13 +
   ' TEXT-ALIGN: left;'#13 +
   '}'#13 +
   'TH.gridr {'#13 +
   ' TEXT-ALIGN: right;'#13 +
   '}'#13 +
   'TH.gridc {'#13 +
   ' TEXT-ALIGN: center;'#13 +
   '}'#13 +
   '< /STYLE> '#13 +
   '< TITLE> Печать таблицы< /TITLE> '#13 +
   '< /HEAD> '#13 +
   '< BODY> '#13;
  HTMLEnd = '< /BODY> < /HTML> ';
  TableStart = '< TABLE WIDTH=" 100%"  CELLSPACING=0 CELLPADDING=1> '#13;
  TableEnd = '< /TABLE> '#13;
  HeaderRowStart = '< TR> '#13;
  HeaderRowEnd = '< /TR> '#13;
  BodyRowStart = '< TR> '#13;
  BodyRowEnd = '< /TR> '#13;
const
  StyleNames: array [TAlignment] of String = ('grid', 'gridr',
'gridc');
  function TD(Column: TColumn; IsTitle: Boolean; Widht: Integer):
String;
  var
    S: String;
    Align: TAlignment;
    Tag: String;
  begin
    if IsTitle then begin
      Tag := 'TH';
      Align := Column.Title.Alignment;
      S := StyleNames[Align];
    end else begin
      Tag := 'TD';
      Align := Column.Alignment;
      if Align = taLeftJustify then begin
        if (Column.Field is TBCDField) or
           (Column.Field is TCurrencyField) then
          Align := taRightJustify;
        if (Column.Field is TBooleanField) then
          Align := taCenter;
      end;
      S := StyleNames[Align];
      if (Column.Field is TBCDField) or (Column.Field is
TIntegerField) then
        S := S + ' NOWRAP'
    end;
    if Widht >  0 then
      S := S + Format(' WIDTH=" %d%%" ', [Widht]);
    Result := '< ' + Tag + ' class=' + S + '> ';
    if IsTitle then begin
      S := Column.Title.Caption
    end else begin
      if Column.Field is TBooleanField then
      with TBooleanField(Column.Field) do begin
        if Length(DisplayValues) = 0 then begin
          if AsBoolean then
            S := 'да'
          else
            S := 'нет';
        end else
          S := Column.Field.DisplayText;
      end else
        S := Column.Field.DisplayText;
    end;
    if Length(Trim(S)) = 0 then
      S := ' ';
    Result := Result + S + '< /' + Tag + '> '#13;
  end;
var
 BM : String;
 I : Integer;
 Widhts: array of Integer;
 TotalWidht: Integer;
begin
  Result := '';
  with Grid  do begin
    if Assigned(DataSource) and
       Assigned(DataSource.DataSet) and
       DataSource.DataSet.Active then
    with DataSource.DataSet do begin
      DisableControls;
      BM := BookMark;
      SetLength(Widhts, Columns.Count);
      TotalWidht := 0;
      for I := 0 to Pred(Columns.Count) do begin
        if Assigned(Columns[I].Field) then begin
          Widhts[I] := Columns[I].Width;
          Inc(TotalWidht, Widhts[I]);
        end;
      end;
      for I := 0 to High(Widhts) do begin
        Widhts[I] := Widhts[I] * 100 div TotalWidht;
      end;
      Result := HTMLStart;
      Result := Result + TableStart;
      if (ghWithHeaders in ExportOptions) then begin
        Result := Result + HeaderRowStart;
        for I := 0 to Pred(Columns.Count) do begin
          if Assigned(Columns.Items[I].Field) then begin
            Result := Result + TD(Columns.Items[I], TRUE, Widhts[I]);
          end;
        end;
        Result := Result + HeaderRowEnd;
      end;
      First;
      while not Eof do begin
        Result := Result + BodyRowStart;
        for I := 0 to Pred( Columns.Count ) do begin
          if Assigned(Columns.Items[I].Field) then begin
            Result := Result + TD(Columns.Items[I], FALSE,
-1{Integer(Widhts[Index]});
          end;
        end;
        Result := Result + BodyRowEnd;
        Next;
      end;
      Result := Result + TableEnd + HTMLEnd;
      BookMark := BM;
      EnableControls;
    end;
  end;
end;

Перемещение по таблице с помощью вертикальной полосы прокрутки.

В DBGRID.PAS измените две следующих процедуры:

procedure TCustomDBGrid.UpdateScrollBar;
var
  Pos: Integer;
  mPos, mMax: longint;
begin
  if FDatalink.Active and HandleAllocated then
    with FDatalink.DataSet do
    begin
      UpdateCursorPos;
      if (DBIGetSeqNo(Handle, mPos) = DBIERR_NONE) then
      begin
        mMax := RecordCount;
        while mMax > 1000 do
        begin
          mMax := mMax div 10;
          mPos := mPos div 10;
        end;
        SetScrollRange(Self.Handle, SB_VERT, 1, mMax, False);
      end
      else
      begin
        if BOF then
          mPos := 0
        else if EOF then
          mPos := 4
        else
          mPos := 2;
        SetScrollRange(Self.Handle, SB_VERT, 0, 4, False);
      end; (**)
      if GetScrollPos(Self.Handle, SB_VERT) <> mPos then
        SetScrollPos(Self.Handle, SB_VERT, mPos, True);
    end;
end;
procedure TCustomDBGrid.WMVScroll(var Message: TWMVScroll);
var
  mMin, mMax: integer;
  RecCount, RecNo, NewRecNo: longint;
begin
  if not AcquireFocus then
    Exit;
  if FDatalink.Active then
    with Message, FDataLink.DataSet, FDatalink do
      case ScrollCode of
        SB_LINEUP: MoveBy(-ActiveRecord - 1);
        SB_LINEDOWN: MoveBy(RecordCount - ActiveRecord);
        SB_PAGEUP: MoveBy(-VisibleRowCount);
        SB_PAGEDOWN: MoveBy(VisibleRowCount);
        SB_THUMBPOSITION:
          if (DBIGetSeqNo(Handle, RecNo) = DBIERR_NONE) then
          begin
            GetScrollRange(self.Handle, SB_VERT, mMin, mMax);
            NewRecNo := Pos * (FDataLink.DataSet.RecordCount div mMax);
            MoveBy(NewRecNo - RecNo);
          end
          else
            case Pos of
              0: First;
              1: MoveBy(-VisibleRowCount);
              2: Exit;
              3: MoveBy(VisibleRowCount);
              4: Last;
            end;
        SB_BOTTOM: Last;
        SB_TOP: First;
      end;
end;

P.S. Пока вы ковыряетесь в DBGRIDS.PAS: найдите и замените TitleColor на FixedColor в TCustomDBGrid.Create и в TCustomDBGrid.DrawCell. Значение свойства FixedColor влияет на показ заголовков колонок, и они будут выводится как и ожидалось.

Корректная работа при работе с колесиком мышки в TDBGrid.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{....}
 public
   procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
      {....}
 procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
 var
   i: SmallInt;
 begin
   {Mouse wheel behaves strangely with dgbgrids - this proc sorts this out}
   if Msg.message = WM_MOUSEWHEEL then
   begin
     Msg.message := WM_KEYDOWN;
     Msg.lParam := 0;
     i := HiWord(Msg.wParam);
     if i > 0 then
       Msg.wParam := VK_UP
     else
       Msg.wParam := VK_DOWN;
     Handled := False;
   end;
 end;
   // Und im Projekt Source: 
  // And in the project source: 
{....}
 Application.OnMessage := Form1.AppMessage;
 {....}

DBGrid компонент, который отображает разными цветами удалённые, обновлённые и добавленные записи.

unit atcDBGrid;
(*
(c) Aveen Tech
2001 - 2002
FileName: atcDBGrid.pas
Version Date Author Comment
1.0 13/06/2000 Majid Vafai Jahan Create.
OVERVIEW
- This grid is inherited from DBGrid and add some required functionality to it.
Functionality:
- Record type are all records that may be modified, unmodified, inserted, deleted.
- Coloring according to Record type.
- show selected Record Type.
*)
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, dbTables, db;
const
  AlignFlags : array [TAlignment] of Integer =
  ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
  DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
  DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
  RTL: array [Boolean] of Integer = (0, DT_RTLREADING);
type
  TCachedShow = (csModify, csUnModify, csRemoved, csInserted, csAll, csNormal);
  TatcDBGrid = class(TDBGrid)
private
  FCachedShow: TCachedShow;
  FModifiedColor: TColor;
  FInsertedColor: TColor;
  FDeletedColor: TColor;
  procedure SetCachedShow(const Value: TCachedShow);
protected
  procedure DrawDataCell(const Rect: TRect; Field: TField; State: TGridDrawState); override;
  procedure DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); override;
public
  constructor Create(AOwner: TComponent); override;
published
  property atcCachedShow: TCachedShow read FCachedShow write SetCachedShow;
  property atcDeletedColor: TColor read FDeletedColor write FDeletedColor;
  property atcInsertedColor: TColor read FInsertedColor write FInsertedColor;
  property atcModifiedColor: TColor read FModifiedColor write FModifiedColor;
end;
procedure register;
implementation
procedure register;
begin
  RegisterComponents('ATC DB Compo', [TatcDBGrid]);
end;
constructor TatcDBGrid.Create(AOwner: TComponent);
(*
Description: Record Type Showing is All except Deletes.
*)
begin
  inherited;
  FCachedShow := csNormal;
  FDeletedColor := clGray;
  FInsertedColor := clAqua;
  FModifiedColor := clRed;
end;
procedure TatcDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer;
Column: TColumn; State: TGridDrawState);
(*
Description: On Drawing Column Color Updated Records.
*)
var
  ARect: TRect;
begin
  inherited;
  if not Assigned(Column.Field) then
    exit;
  // Copy Rect into Variable.
  CopyRect(ARect, Rect);
  if Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then
  begin
    // если текущая запись изменена
    if DataLink.DataSet.UpdateStatus = usModified then
    begin
      Canvas.Brush.Color := atcModifiedColor;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect,
      AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
    end
    // если текущая запись добавлена.
    else
    if DataLink.DataSet.UpdateStatus = usInserted then
    begin
      Canvas.Brush.Color := atcInsertedColor;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect,
      AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
    end
    // если текущая запись удалена.
    else
    if DataLink.DataSet.UpdateStatus = usDeleted then
    begin
      Canvas.Brush.Color := atcDeletedColor;
      Canvas.Font.Color := clWhite;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect,
      AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
    end;
  end;
end;
procedure TatcDBGrid.DrawDataCell(const Rect: TRect; Field: TField;
State: TGridDrawState);
(*
Описание: Рисуем ячейки
*)
var
  ARect: TRect;
begin
  inherited;
  CopyRect(ARect, Rect);
  if Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then
  begin
    // если текущая запись изменена
    if DataLink.DataSet.UpdateStatus = usModified then
    begin
      Canvas.Brush.Color := clRed;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
      AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]);
    end
    // если текущая запись добавлена.
    else
    if DataLink.DataSet.UpdateStatus = usInserted then
    begin
      Canvas.Brush.Color := clAqua;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
      AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]);
    end
    // если текущая запись удалена.
    else
    if DataLink.DataSet.UpdateStatus = usDeleted then
    begin
      Canvas.Brush.Color := clGray;
      Canvas.Font.Color := clWhite;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
      AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]);
    end;
  end;
end;
procedure TatcDBGrid.SetCachedShow(const Value: TCachedShow);
(*
Description: Record type for showing in grid.
Parameters: Value cached record show.
*)
begin
  FCachedShow := Value;
  if ComponentState = [csDesigning] then
    exit;
  if not Assigned(DataSource) or not Assigned(DataSource.DataSet) then
    exit;
  // для показа только выбранного типа записей.
  if Assigned(DataLink) and Assigned(DataLink.DataSet) and (DataLink.Active) then
  begin
    case FCachedShow of
      csAll:
        TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted, rtDeleted, rtUnmodified];
      csModify:
        TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified];
      csUnModify:
        TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtUnmodified];
      csInserted:
        TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtInserted];
      csRemoved:
        TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtDeleted];
      csNormal:
        TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted, rtUnmodified];
    end;
  end;
end;
end.

DBGrid c FixedCols.

Я делаю это таким образом:

unit Fcdgrid;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, DBGrids, DBCtrls, DB, Menus;
type
  TFixedColDBGrid = class(TDBGrid)
  private
    FUserFixedCols: Integer;
  protected
    procedure LayoutChanged; override;
    procedure SetUserFixedCols(I: Integer);
  published
    property UserFixedCols: Integer read FUserFixedCols write SetUserFixedCols;
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Data Controls', [TFixedColDBGrid]);
end;
procedure TFixedColDBGrid.LayoutChanged;
begin
  inherited LayoutChanged; {   присваиваем FixedCols 1 если индикатор, иначе 0 }
  if ((inherited FixedCols + FUserFixedCols) < inherited ColCount) then
    inherited FixedCols := (FUserFixedCols + inherited FixedCols);
end;
procedure TFixedColDBGrid.SetUserFixedCols(I: Integer);
begin
  FUserFixedCols := I;
  LayoutChanged;
end;
end.

DBGrid с номером строки.

Скомпилируйте это, и вы получите новый компонент с нужными свойствами:

unit RowGrid;
interface
uses
  WinTypes, WinProcs, Classes, Grids, DBGrids;
type
  TRowDBGrid = class(TDBGrid)
  public
    property Row;
    property RowCount;
    property VisibleRowCount;
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Data Controls', [TRowDBGrid]);
end;
end.

{вот небольшой испытательный демо-проект.. мы
поместили на форму нашу сетку-наследницу, 3 компонента
EditBox и поместили следующий код в обработчик события
ondrawdatacell вашего TRowGrid}
procedure TForm1.RowDBGrid1DrawDataCell(Sender: TObject; const Rect:
  TRect; Field: TField; State: TGridDrawState);
begin
  eb_row.text := inttostr(rowdbgrid1.row);
  eb_rowcount.text := inttostr(rowdbgrid1.rowcount);
  eb_visiblerowcount.text := inttostr(rowdbgrid1.visiblerowcount);
end;

Синтаксис функции DbiAddAlias.

   DBIResult DbiAddAlias( [hCfg], pszAliasName, pszDriverType, pszParams, bPersistent );

   DbiAddAlias добавляет псевдоним в конфигурационный файл, связанный с
   текущим сеансом.

   hCfg              Type: hDBICfg              (Входящий)
      Для BDE 2.5 данный параметр должен быть NULL. Указывает, что
      конфигурация действует в течение текущего сеанса.
      Другие значения для BDE 2.5 не поддерживаются.
   pszAliasName      Type: pCHAR                (Входящий)
      Указатель на имя псевдонима. Это имя нового псевдонима, который
      должен быть добавлен.
   pszDriverType     Type: pCHAR                (Входящий)
      Указатель на тип устройства. Это тип устройства для добавляемого
      псевдонима. Если данный параметр NULL, псевдоним будет добавлен 
      для базы данных STANDARD. Если указан szPARADOX, szDBASE или szASCII, 
      будет добавлена запись в генератор псевдонимов базы данных STANDARD 
      для указания того, что данный тип будет предпочтительным типом 
      устройства. Если указано имя устройства, то оно должно существовать
      в измененном файле конфигурации.
   pszParams         Type: pCHAR                (Входящий)
      Указатель на список дополнительных параметров. Данный список 
      определяется следующим образом: 
      "AliasOption: Option Data[;AliasOption: Option Data][;...]".
      AliasOption должен соответствовать одному из значений, возвращаемому 
      DbiOpenCfgInfoList. Для псевдонимов базы данных STANDARD, единственно
      необходимый параметр - PATH, остальные игнорируются (без ошибок). 
      
      Пример 1: Чтобы установить путь для использования базы данных
        STANDARD:
         "PATH:c:\mydata"
      Пример 2: Чтобы установить имя сервера и имя пользователя для 
        использования драйвера SQL: 
         "SERVER NAME: server:/path/database;USER NAME: myname"
   bPersistent       Type: BOOL                 (Входящий)
      Определяет область действия нового псевдонима.
         TRUE     Сохраняется в файле конфигурации для будующих сеансов.
         FALSE    Для использования только в течение текущего сеанса. 
                  Псевдоним удаляется в конце сеанса (или при выходе из
                  программы).
Использование:
   Созданный данной функцией псевдоним будет иметь параметры по умолчанию,
   хранимые в списке параметров драйверов "DB OPEN", если только оне не
   перекрыты в параметре pszParams. Вы можете использовать 
   DbiOpenCfgInfoList, чтобы изменить значение по умолчанию после добавления 
   псевдонима с помощью DbiAddAlias.
   
   Для псевдонимов стандартной базы данных все параметры pszParams за
   исключением PATH игнорируются.
Предварительные условия:
   DbiInit должен вызываться до вызова DbiAddAlias. 
   
Возвращаемые значения DBIResult:
   DBIERR_INVALIDPARAM
      Имя псевдонима Null или один из следующих типов pszDriverType: 
      szASCII, szDBASE, szPARADOX. В последнем случае используйте
      NULL pszDriverType для указания на базу данных STANDARD.
   DBIERR_NONE
      Псевдоним был успешно добавлен.
   DBIERR_NAMENOTUNIQUE
      Существует другой псевдоним с тем же именем (работает
      когда bPersistent равен TRUE).
   DBIERR_OBJNOTFOUND
      Один (или более) из дополнительных параметров, указанных в 
      pszParams не соответствуют правильным типам в секции драйверов 
      конфигурационного файла.
   DBIERR_UNKNOWNDRIVER
      Имя устройства в конфигурационном файле при сопоставлении с 
      pszDriverType не найдено.
Смотри также:
   DbiInit, DbiOpenCfgInfoList

Пример DbiAddFilter.

Автор: Mark Erbaugh

type
  TmyFilter = record
    Expr: CANExpr;
    Nodes: array[0..2] of CANNode;
    literals: array[0..7] of char;
  end;
const
  myFilter: TMyFilter = (Expr:
    (iVer: 1; iTotalSize: sizeof(TMyFilter); iNodes: 3;
    iNodeStart: sizeof(CANExpr); iLiteralStart: sizeof(CANExpr) +
    3 * sizeof(CANNode));
    Nodes:
    ((canBinary: (nodeClass: nodeBinary; canOP: canEQ;
    iOperand1: sizeof(CANNode); iOperand2: 2 * sizeof(CANNode))),
    (canField: (nodeClass: nodeField; canOP: canField2;
    iFieldNum: 0; iNameOffset: 0)),
    (canConst: (nodeClass: nodeConst; canOP: canCONST2;
    iType: fldZSTRING; iSize: 3; iOffset: 5)));
    literals:
    ('T', 'Y', 'P', 'E', #0, 'I', 'N', #0));
var
  dbResult: DBIResult;
  hFilter, hFilter1: hDBIFilter;
begin (* procedure SetupFilter *)
  dbResult := DbiAddFilter(tblAP_.Handle, 1, 1,
    False, addr(myFilter), nil, hFilter);
  dbResult := DbiActivateFilter(tblAP_.Handle, hFilter);
  tblAP_.First;
  myFilter.nodes[0].canBinary.canOp := canNE;
  dbResult := DbiAddFilter(tblAP1_.Handle, 1, 1,
    False, addr(myFilter), nil, hFilter1);
  dbResult := DbiActivateFilter(tblAP1_.Handle, hFilter1);
  tblAP1_.First;
  myFilter.nodes[0].canBinary.canOp := canEQ;
end;

Также необходимо включить в ваш файл файлы DBITYPES и DBIPROCS, где определены вызываемые функции и константы.

Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE.

Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))

Или, если известно, что эта картинка - Bitmap, то можно.

Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

А можно воспользоваться компонентом TDBImage.

Значение DBLookupComboBox.

Я надеюсь что помог вам.

unit clookup;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, DB, DBLookup;
type
  TDBJustLookupCombo = class(TDBLookupCombo)
  private
    { Private declarations }
  protected
    { Protected declarations }
    function GetLValue: TField;
  public
    { Public declarations }
    property LookUpValue: TField read GetLValue;
  published
    { Published declarations }
  end;
  TDBJustLookupList = class(TDBLookupList)
  private
    { Private declarations }
  protected
    { Protected declarations }
    function GetLValue: TField;
  public
    { Public declarations }
    property LookUpValue: TField read GetLValue;
  published
    { Published declarations }
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Data Controls', [TDBJustLookupList,
    TDBJustLookupCombo]);
end;
function TDBJustLookupCombo.GetLValue: TField;
begin
  Result := LookupSource.DataSet.FieldByName(LookUpField);
end;
function TDBJustLookupList.GetLValue: TField;
begin
  Result := LookupSource.DataSet.FieldByName(LookUpField);
end;
end.

Обновить DBLookUpComboBox при скролинге таблицы.

Есть табличка, к ней привязан TDBLookupComboBox. Значение в нем отображается только после клика мышкой. Как заставить его перерисоваться после изменения текущей записи в таблице, к которой он привязан?

DBLookupComboBox.KeyValue := Table1.FieldByName('Field1').Value;

Показываемое DBLookupComboBox значение.

Следующая строка в обработчике события OnActivate:

DBLookupCombox1.Perform(WM_KeyDown,38,0);

Заполняет показываемое в dblookupcombox значение. Вы посылаете сообщение индекса непосредственно в dblookupcombox.

Поиск текста в DBMemo.

Попробуйте так: "Подключите" следующую процедуру к событию OnFind для FindDialog. Единственная проблема заключается в том, что в DBMemo я не могу получить выделенный текст, тем не менее в стандартном Memo такой проблемы нет.

procedure TMainForm.FindDialog1Find(Sender: TObject);
var
  Buff, P, FT: PChar;
  BuffLen: Word;
begin
  with Sender as TFindDialog do
  begin
    GetMem(FT, Length(FindText) + 1);
    StrPCopy(FT, FindText);
    BuffLen := DBMemo1.GetTextLen + 1;
    GetMem(Buff, BuffLen);
    DBMemo1.GetTextBuf(Buff, BuffLen);
    P := Buff + DBMemo1.SelStart + DBMemo1.SelLength;
    P := StrPos(P, FT);
    if P = nil then
      MessageBeep(0)
    else
    begin
      DBMemo1.SelStart := P - Buff;
      DBMemo1.SelLength := Length(FindText);
    end;
    FreeMem(FT, Length(FindText) + 1);
    FreeMem(Buff, BuffLen);
  end;
end;

Попробуйте так: "Подключите" следующую процедуру к событию OnFind для FindDialog. Единственная проблема заключается в том, что в DBMemo я не могу получить выделенный текст, тем не менее в стандартном Memo такой проблемы нет.

begin
  DBMemo1.SelStart:= P - Buff;
  DBMemo1.SelLength:= Length(FindText);
end;
  FreeMem(FT, Length(FindText) + 1);
  FreeMem(Buff,BuffLen);
  DBMemo1.SetFocus;
end;

Выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки.

set serveroutput on size 10000;

Выключение кнопок в DBNavigator.

{ Расширение DBNavigator: позволяет разработчику включать и выключать
отдельные кнопки через методы EnableButton и DisableButton }
unit GNav;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, DBCtrls;
type
  TMyNavigator = class(TDBNavigator)
  public
    procedure EnableButton(Btn: TNavigateBtn);
    procedure DisableButton(Btn: TNavigateBtn);
  end;
procedure Register;
implementation
procedure TMyNavigator.EnableButton(Btn: TNavigateBtn);
begin
  Buttons[Btn].Enabled := True;
end;
procedure TMyNavigator.DisableButton(Btn: TNavigateBtn);
begin
  Buttons[Btn].Enabled := False;
end;
procedure Register;
begin
  RegisterComponents('Samples', [TMyNavigator]);
end;
end.

Свойства кнопок DBNavigator.

Для определения видимости вы можете использовать свойство VisibleButtons. Например:

if nbRefresh in DBNavigator1.VisibleButtons then
  ShowMessage('Кнопка Refresh видимая') ;

Для того, чтобы узнать, активизирована (enabled/disabled) кнопка или нет:

{Вместо nbFirst вы можете определить другой
член TNavigateBtn (например, nbFirst, nbPrior,
nbNext, nbLast, nbInsert, nbDelete, nbEdit,
nbPost, nbCancel, nbRefresh)}
if DBNavigator1.Controls[Ord(nbFirst)].Enabled then
  ShowMessage('Кнопка First активизирована') ;

Вызов кнопок DBNavigator.

Я делаю приблизительно так:

DBNavigator1.BtnClick(nbInsert);

Я не знаю, задокументирована эта "фича", рекомендована ли для таких случаев... Просто у меня это работает и я этим пользуюсь.

Настройки всплывающих подсказок в DBNavigator.

procedure TForm1.Button1Click(Sender: TObject);
var
  ix: integer;
begin
  with DBNavigator1 do
    for ix := 0 to ControlCount - 1 do
      if Controls[ix] is TNavButton then
        with Controls[ix] as TNavButton do
          case index of
            nbFirst: Hint := 'Подсказка для кнопки First';
            nbPrior: Hint := 'Подсказка для кнопки Prior';
            nbNext: Hint := 'Подсказка для кнопки Next';
            nbLast: Hint := '';
            {......}
          end;
end;

DBNavigator без иконок.

var
  c: shortint;
  s: string;
begin
  s := 'A';
  with DBNavigator1 do
    for c := 0 to ControlCount - 1 do
      if Controls[c] is TNavButton then
        with TNavButton(Controls[c]) do
        begin
          ListBox1.Items.Add(Name);
          Glyph := nil;
          Caption := s;
          Inc(s[1]);
        end;
end;

DBTreeView своими руками.

Автор: Елена Филиппова Специально для Королевства Delphi

Введение

В статье речь пойдет об отображении данных, хранящихся в БД и имеющих иерархическую (древовидную) структуру. Визуальное представление таких данных требует соответствующего инструмента. Существует немало компонент, которые позволяют представлять данные в виде дерева — для краткости будем называть их все DB TreeView. Компоненты эти довольно удобны, но, как правило, "заточены" под определенные задачи и каждый "шаг в сторону" в структуре данных заставляет многих пускаться в поиски. И на Круглом Столе появляются вопросы: "помогите найти компонент DB TreeView, который позволяет делать еще и ..." и так далее.

А ведь в Delphi существует стандартный компонент для представления древовидных данных, это знакомый всем TTreeView, его возможностей хватает с лихвой практически для всех задач по отображению деревьев. Сделать из TreeView самый настоящий DB TreeView, да еще полностью контролировать его развитие, более перспективный путь, нежели каждый раз искать новый чужой компонент.

Весь этот материал основан на моем личном опыте и, естественно, не обязательно является самым оптимальным вариантом. Это частное мнение, которым я просто хочу поделиться.

Рассмотрим два принципиально разных случая:

Отличаются эти примеры стуктурой данных и, соответственно, способом формирования дерева.

Тем не менее сущестуют общие правила для генерации дерева. Во-первых, я исхожу из предположения, что все дерево сразу с большой степенью вероятности не понадобится пользователю. Более того, сам процесс формирования TTreeView довольно длительный и занимает ощутимое время, особенно если работать с большим объемом БД.

Гораздо правильнее строить отдельные ветки дерева динамически, только в тот момент, когда они наверняка понадобятся.

То есть, в самый начальный момент необходимо сформировать только самый верхний уровень дерева. Затем, по мере требования, можно достраивать очередную ветвь.

Какой же момент можно считать моментом требования? В принципе есть два равнозначных варианта и отличаются они только внешним видом.

Основное отличие этих подходов: в первом случае пользователю необходимо сделать явно лишнее и не очень естественное для дерева движение , то есть двойной клик. А во втором случае мы должны обеспечить возможность раскрытия для каждой ветки дерева, ведь если у ветви нет значка [+] , то и попытаться раскрыть ее будет невозможно. А значит для всех новых, свеже сформированных ветвей, принудительно нужно обеспечить существования фиктивной дочерней ветви.

Можете сами выбрать, что Вам удобнее, я использую второй вариант.

На сервере http://ib.demo.ru/ была опубликована статья Кузьменко Дмитрия Древовидные (иерархические) структуры данных в реляционных базах данных , часть которой посвящена теме визуального представления древовидных данных. В этой статье предлагалось хранить в таблице дополнительное поле с количеством дочерних записей для каждой ветви именно для того, чтобы иметь возможность принимать решение рисовать или не рисовать знак [+] возле текущей ветки дерева. То есть на ходу определять, имеет ли шанс эта ветка быть раскрытой.

Следовательно, только для процесса визуализации требуется изменять структуру данных, добавлять триггеры для сохранения целостности дополнительной информации.

Каждый способ имеет свои достоинства и недостатки, но мне кажется несколько неоправданным такой подход, когда структура таблиц зависит от способа их отображаения. В примерах, которые иллюстрируют материал этой статьи применяется использование фиктивных дочерних ветвей для обеспечения появления у каждой ветви значка [+].

Примечание:

Дерево подразделеений

Пусть у нас существует таблица подразделений, каждое из которых может иметь свои внутренние подразделения. Необходимо отображать эти данные в виде дерева.

Используемая в примере таблица — COMPANY.DB.

Структура данных реализована классическим деревом: каждая запись о подразделении представлена полями.

Для тех подразделений, которые не имеют головных над собой, поле ParentID равно 0.

Формировать уровни дерева мы будем с помощью запроса к таблице ( компонент qTreeCompanies : TQuery ).

Select * From COMPANY
Where ParentID=:ParentID

Параметр ParentID будет определять, какую ветку мы сейчас достраиваем. То есть, к какой ищем дочерние подразделения.

Процедура, формирующая очередной уровень (дочерний для ветви Node ) реализована следующим образом:

Procedure TFormTree.ExpandLevel( Node : TTreeNode);
Var ID , i   : Integer;
    TreeNode : TTreeNode;
Begin
    // Для самого верхнего уровня выбрать только тех,
    // кто не имеет родителей.
    IF Node = nil Then ID:=0
    Else ID:=Integer(Node.Data);
    qTreeCompanies.Close;
    qTreeCompanies.ParamByName('ParentID').AsInteger:=ID;
    qTreeCompanies.Open;
          
    TreeCompanies.Items.BeginUpdate;
 
    // Для каждой строки из полученного набора данных
    // формируем ветвь в TreeView, как дочерние ветки к той,
    // которую мы только что "раскрыли"
    For i:=1 To qTreeCompanies.RecordCount Do
    Begin
       // Запишем в поле Data ветки ее идентификационный номер(ID) в таблице
       TreeNode:=TreeCompanies.Items.AddChildObject(Node ,
                                  qTreeCompanies.FieldByName('Name').AsString ,
                                  Pointer(qTreeCompanies.FieldByName('ID').AsInteger));
       TreeNode.ImageIndex:=1;
       TreeNode.SelectedIndex:=2;
       // Добавим фиктивную (пустую) дочернюю ветвь только для того,
       // чтобы был отрисован [+] на ветке и ее можно было бы раскрыть
       TreeCompanies.Items.AddChildObject(TreeNode , '' , nil);
       qTreeCompanies.Next;
    End;   
 
    TreeCompanies.Items.EndUpdate;
End;

Теперь позаботимся о том, чтобы она вызывалась в нужный нам момент времени. На событие OnExpanding проверим, есть ли у текущей ветки фиктивная дочерняя ветвь и, если она есть, сформируем реальную ветку, предварительно удалив фиктивную.

if Node.getFirstChild.Data = nil then
begin
  Node.DeleteChildren;
  ExpandLevel(Node);
end;

На форме в проекте кроме дерева расположена еще и сетка (Grid), в которой отображаются записи текущего уровня подразделений. Это, по сути, список дочерних ветвей для текущей ветки дерева. Для того, чтобы синхронизировать TreeView и DBGrid используем нехитрый прием — на событие TTreeView.OnChange (шаг по ветке) добавим следующий код:

IF TreeCompanies.Selected <> nil Then
Begin
  // ID родительской ветки , для нее и ищем все дочерние
  ID:=Integer(TreeCompanies.Selected.Data);
  
  qCompanies.Close;
  qCompanies.ParamByName('ParentID').AsInteger:=ID;
  qCompanies.Open;
End;

Помните, в процедуре ExpandLevel мы записывали в поле Data каждой ветки ее идентификационный номер? Вот его то мы сейчас и используем.

Для полного ощущения передвижения по Grid'у, как по дереву можно добавить эффект "проваливания" на более глубокий уровень. По двойному клику на записи в Grid'е пользователь проваливается на один уровень вниз по иерархии, если такой уровень, конечно же еще есть.

На событие OnDblClick для грида:

ID:=qCompanies.FieldByName('ID').AsInteger;
// принудительное "невидимое" раскрытие той ветки, на которой стоим
TreeCompanies.OnExpanding(TreeCompanies ,TreeCompanies.Selected , Allow);
// Перебираем все получившиеся дочерние ветки и ищем ту, ID которой
// совпадает с ID строки в правой таблице. То есть ищем ветку в дереве,
// которая соответсвует той записи в таблице, на которой мы стоим
// Как только нашли, визуально раскрываем ветку и делаем ее выделенной,
// то есть визуально "встаем" на нее в дереве
FOR i:=0 To TreeCompanies.Selected.Count-1 Do
  IF Integer(TreeCompanies.Selected.Item[i].Data) = ID Then
  Begin
    TreeCompanies.Selected.Item[i].Expand(False);
    TreeCompanies.Selected.Item[i].Selected:=True;
    TreeCompanies.Repaint;
    Exit;
  End;

Параллельно с этим раскрывается соответствующая ветка самого дерева. Очень эффектно. :о).

В проекте реализована возможность добавления новых ветвей, то есть новых подразделений. Нажимте на TreeView правую кнопку мышки и достраивайте наше дерево, как Вам угодно!

Дерево аналитических признаков

"Куст — это пучок веток, растущих из одного места" из военных афоризмов.

Пусть у нас есть таблица документов, каждый документ, например, описывает некоторую операцию по покупке( или продаже ) товара. В этой операции участвуют: определенный товар, клиент, у которого куплен (или которому продан) этот товар, и город, в котором данная операция совершена. Таким образом, мы имеем таблицу документов, каждая запись в которой наделена тремя аналитическими признаками: Город, Клиент и Товар.

По сути своей эти данные не являются иерархическими, и никакой явной зависимости между документами не прослеживается. Но тем не менее эта связь существует — одинаковые аналитические признаки. Например, в одну группу можно объединить все документы, имеющие отношение к определенному товару или клиенту.

Если для анализа данных пользователю необходимо работать с документами по зафиксированным аналитическим признакам, то возникает задача визуального представления таких данных. К примеру, заказчик требует показывать ему все документы для определенного города, а потом, для определенного клиента и товара, но в том же городе. Однако желательно видеть информацию ровно в обратном порядке: сначала выбрать документы с нужным товаром, затем увидеть все города, где работали с этим товаром, выбирать нужный город и так далее.

Явно прослеживается древовидная структура, где каждый уровень дерева суть аналитический признак. Именно поэтому, как говорилось выше, в данном дереве фиксирована глубина вложенности. Она однозначно определяется количеством аналитики для документа.

Описание примера, реализующего данную задачу

Используемые таблицы:

Таблица документов DOCUMENTS.DB , где каждый документ определен полями:

Таблицы аналитики, соответственно CITIES.DB, CLIENTS.DB и GOODS.DB, содержат поля названия Name и номера (CityID , ClientID , GoodID).

Так как порядок следования аналитики произвольный, зараннее невозможно написать текст SQL-запроса, который будет возвращать данные для очередного уровня дерева. Этот текст придется формировать в run-time, когда все данные будут известны.

Чтобы не зашиваться именно на такой список аналитики, который приведен в примере, стоит затратить немного больше сил и обеспечить себе некоторую универсальность. Для этого добавим еще одну таблицу (таблицу сущностей) Entities, содержащую описание используемой аналитики.

Поля таблицы ENTITIES.DB.

В нашем случае эта таблица будет выглядеть так:

В примере я использую список ListEntities (TCollection), каждый элемент которого содержит поля TableName, KeyColumn и ImageIndex. Элементы в этом списке расположены в том порядке, в каком будет строиться дерево. Заполняется этот список только той аналитикой, которая требуется для конкретного дерева. Например, только города и клиенты или товары и клиенты, или сразу все вместе. Следовательно этот список (ListEntities) и содержит полную информацию для построения дерева в каждый конкретный момент.

Заполнение списка аналитики проводится в модуле setupEntities.pas.

//считывает аналитику из таблицы
procedure GetEntities( var List : TEntityLists ); 
// вызывает диалог для настойки аналитики пользователем
function SetEntities( var List : TEntityLists ) : Boolean;

Формирование дерева в этом случае полностью аналогично предыдущему примеру, с той только разницей, которая касается формирования текста запроса для каждого уровня дерева.

Так же в дерево добавляется единый для всех веток самый верхний корневой узел. С точки зрения аналитики это "фиктивный" узел, так как он будет отображать ВСЕ документы, без указания конкретного значения аналитического признака. Кроме того, достраивается еще один, самый нижний уровень — список документов по зафиксированной для текущей ветки аналитики.

Наличие этих "фиктивных" узлов совершенно не обязательно, но, на мой взгляд, очень логично.

В итоге, глубина вложенности дерева будет равна "количество аналитики" + 2.

Итак, процедура ExpandLevel будет модифицирована следующим образом:

Procedure TFormTree.ExpandLevelAnalytic(Node : TTreeNode );
Var NewItem    : TListsItem;
    ImageIndex ,
    Level , i  : Integer;
    TreeNode   : TTreeNode;
    Sql,Name   : String;
Begin
     IF Node = nil Then Exit;
     TreeAnalytic.Items.BeginUpdate;
     Level:=Node.Level + 1; // уровень, который будет раскрываться
     // Самому первому аналитическому признаку в списке  ListEntities
     // соответсвует _второй_ физический уровень веток дерева.
     // Так как самый верхний уровень дерева фиктивный -"все документы"
     // Отсюда и игра с (+/-) 1 при обращении к списку
     qTreeAnalytic.Close;
     // Определим, на каком типе уровня мы сейчас находимся
     //
     IF Level > ListEntities.Count
     Then Begin  // Уровень документов, аналитка закончилась
            Sql:='SELECT * FROM Documents Where '+ GetSqlPath(Node);
            Name:= 'DocumentID';
            ImageIndex:=3;
          End
     Else Begin // Очередной уровень аналитики
            Sql:='SELECT DISTINCT '+ ListEntities[Level-1].AsString + '.* ' +
                 ' FROM Documents , ' +  ListEntities[Level-1].AsString + ' WHERE ' +
                 ListEntities[Level-1].AsString + '.' +ListEntities[Level-1].Name + '=' +
                 'Documents.'+ListEntities[Level-1].Name + ' AND ' + GetSqlPath(Node) ;
            Name:=ListEntities[Level-1].Name;
            ImageIndex:=ListEntities[Level-1].ImageIndex;
          End;
     qTreeAnalytic.Sql.Clear;
     qTreeAnalytic.Sql.Add(Sql);
     qTreeAnalytic.Open;
      
  // Получен очередной уровень ветвей дерева
     For i:=1 To qTreeAnalytic.RecordCount Do
     Begin
         NewItem:=List.AddItem(qTreeAnalytic.FieldByName(Name).AsInteger , Name);
         TreeNode:=TreeAnalytic.Items.AddChildObject( Node ,
                              qTreeAnalytic.FieldByName('Name').AsString, NewItem );
         TreeNode.ImageIndex:=ImageIndex;
         TreeNode.SelectedIndex:=TreeNode.ImageIndex;
         // Фиктивная дочерняя ветка ТОЛЬКО для уровней аналитики,
         // так как документы - последний уровень, за которым ничего и не может быть
         IF Level <= ListEntities.Count
         Then TreeAnalytic.Items.AddChild(TreeNode , '' );
         qTreeAnalytic.Next;
     End;
     TreeAnalytic.Items.EndUpdate;
End;

В предыдущем примере мы запоминали ID строки из таблицы в поле Data каждой ветви дерева. Сейчас нам не годится такой вариант, так как аналитический признак определяется не одним идентификатором, а целым элементом списка ListEntities, вот его то и надо запоминать. Поэтому в поле Data сохраняется ссылка на конкретный элемент этого списка. Благо это Pointer и записать туда можно все, что угодно.

В процедуре используется функция GetSqlPath, которая возвращает полный путь от корня до указанной ветки дерева. Полный путь это есть зафиксированные значения для каждого уровня аналитики. Эти значения необходимы для того, чтобы верно построить запрос. То есть мы фактически формируем дополнительный фильтр для последующих выборок, напрмер — получаем всех клиентов для конкретного города и указанного товара.

Function TFormTree.GetSqlPath( Node : TTreeNode ) : String;
Begin
   Result:=' 0=0 ' ;
   // Участвуют все ветви дерева, кроме самого верхнего фиктивного уровня
   While Node.Level > 0   Do
   Begin
      Result:= Result + ' AND ' +
               'Documents.' + TListsItem(Node.Data).Name + '=' +
                              TListsItem(Node.Data).AsString ;
      // Делаем шаг назад по ветке дерева
      Node:=Node.Parent;
   End;
End;

Пример текстов SQL запроса, который будет сформирован при движении по дереву:

Уровень "товары" — Все товары, которые встречаются в документах, созданных в городе номер 6 и для клиента номер 3.

SELECT DISTINCT Goods.*  FROM Documents , Goods 
WHERE Goods.GoodsID=Documents.GoodsID AND  0=0  
AND Documents.CityID=6 AND Documents.ClientID=3

Последний уровень "документы" — Все документы, созданные в городе номер 6 и для клиента номер 3, по товару номер 1.

SELECT * FROM Documents Where  0=0  AND
Documents.GoodsID=1 AND Documents.CityID=6 AND Documents.ClientID=3

Такой подход позволяет легко расширять набор аналитических признаков, которые должны использоваться в программе, практически без изменения кода клиентского приложения. Достаточно изменить структуру таблицы DOCUMENTS и дополнить таблицу ENTITIES.

В некоторой степени можно сказать, что таблица ENTITIES содержит метаданные о структуре базы. Правда с большой натяжкой, так как в данном примере структура просто элементарна, а связи слишком просты и не поддерживают никакой глубины вложения (как, например, в таком случае, когда город не указан явно в документе, но может быть вытянут из таблицы клиентов и так далее).

Для получения набора данных не обязательно использовать именно запросы, точно так же можно использовать хранимые процедуры для SQL-серверных СУБД. Изменится структура метаданных, но не изменится принцип формирования дерева.

На мой взгляд, в качестве примера, стоит внимательно рассмотреть такой подход, чтобы вы могли в своих конкретных задачах на его основе конструировать реальные метаданные и без проблем модифицировать дерево аналитических признаков.

Итак...

Итак, были рассмотрены две принципиально разные задачи, а реализация DBTreeView оказалась практически идентична. Собственно, этот факт и является важным результатом статьи — воспользуйтесь примерами, добавьте собственный функционал и создайте для себя несложный компонент для отображения древовидной структуры. Это не значит, что не стоит пользоваться сторонними компонентами, ни в коем случае. Просто если существующие вас не устраивают полностью, вы будете знать, как это исправить.

Для иллюстрации материала статьи подготовлен проект TreeDB :

Проект откомпилирован в Delphi 5, использует BDE и настроен на алиас TreeDB.

Как можно открыть отчёт (в режиме Print Preview а также Print Direct) в MS Access.

var
  Access: Variant;
begin
  // Открываем Access
  try
    Access := GetActiveOleObject('Access.Application');
  except
    Access := CreateOleObject('Access.Application');
  end;
  Access.Visible := True;
  // Открываем базу данных
  // Второй параметр указывает - будет ли база открыта в Exclusive режиме
  Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);
  // открываем отч¸т
  {Значение второго пораметра может быть одним из следующих
  acViewDesign, acViewNormal, or acViewPreview. acViewNormal,
  которые устанавливаются по умолчанию, для печати отч¸та.
  Если Вы не используете библиотеку типов, то можете определить
  эти значения следующими:
  const
  acViewNormal = $00000000;
  acViewDesign = $00000001;
  acViewPreview = $00000002;
  Третий параметр - это имя очереди для текущей базы данных.
  Четв¸ртый параметр - это строка для SQL-евского WHERE -
  то есть строка SQL, минус WHERE.}
  Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
    EmptyParam);
  < ... >
  // Закрываем базу данных
  Access.CloseCurrentDatabase;
  // Закрываем Access
  {const
  acQuitPrompt = $00000000;
  acQuitSaveAll = $00000001;
  acQuitSaveNone = $00000002;}
  Access.Quit(acQuitSaveAll);
end;

Как в Delphi сбросить кэш БД на диск.

uses BDE {в Delphi 1.x не помню, но вроде bdeprocs};
dbiSaveChanges

На Delphi 1.x (16bit) дополнительно вызовите эту процедуру:

procedure DropCache; assembler;
asm
  mov ah,$0D
  int $21
end;

История изменений объектов.

Оформил: DeeCo

Автор: Виноградов С. А.

Большинство объектов, хранящихся в базе данных, могут меняться с течением времени. Например, человек может сменить фамилию, паспорт, место жительства. У различных объектов учета может поменяться цена, количество, стоимость. К сожалению, почти все современные СУБД не хранят историю этих изменений и не позволяют получить состояние объектов на определенную дату. Об этом должен позаботиться проектировщик базы данных.

В качестве примера, возьмем таблицу Objects, которая содержит код объекта, его наименование, примечание и другие поля (здесь и далее — синтаксис MS SQL):

create table[Objects]
(
  [Id]int not null identity primary key,
  [Code]varchar(120) not null,
  [Name]varchar(120) not null,
  [Note]varchar(250),
  ...
  )

Рассмотрим варианты хранения истории для этой таблицы.

По многим соображениям, бывает необходимо оставить таблицу объектов на текущий момент в неизменном виде, а историю вести в отдельной таблице. Самый простой способ хранения истории — при любом изменении в объекте, добавлять в таблицу запись с новыми значениями объекта и приписывать к этой записи дату изменения. Тогда, структура таблиц Objects и ObjectsHistory будет примерно такой:

create table[Objects]
(
  [Id]int not null identity primary key,
  [Code]varchar(120) not null,
  [Name]varchar(120) not null,
  [Note]varchar(250),
  ...
  )
create table[ObjectsHistory]
(
  [object]int not null references[Objects]([Id]),
  [Code]varchar(120) not null,
  [Name]varchar(120) not null,
  [Note]varchar(250),
  ...
  [DateBegin]datetime not null default(getdate()),
  [DateEnd]datetime not null default('3000-01-01')
  constraint[ObjectHistory]primary key([object], [DateBegin])
  )

Первичный ключ в таблице истории состоит из двух полей: идентификатора объекта из основной таблицы (Object) и даты начала действия истории объекта (DateBegin). Дата окончания действия истории (DateEnd) всегда равна дате начала следующей истории объекта, и используется исключительно для более простых условий выборки.

При вставке записи в основную таблицу, необходимо добавить такую же запись в таблицу истории, где Object = идентификатор_объекта, DateBegin = текущая_дата, DateEnd = максимальная_дата.

При модификации записи в основной таблице, нужно вставить измененную запись в таблицу истории, где Object = идентификатор_объекта, DateBegin = текущая_дата, DateEnd = максимальная_дата. При этом у предыдущей записи с таким же идентификатором в таблице истории необходимо установить DateEnd = текущая_дата.

При удалении записи в основной таблице, у последней записи с таким же идентификатором в таблице истории надо установить DateEnd = текущая_дата.

Запись изменений в таблицу истории можно производить триггерами, хранимыми процедурами, или из приложения, используя базовый класс объектов.

Выборка из основной таблицы производится обычным образом, а из таблицы истории с условием:

заданная_дата beetwen DateBegin and DateEnd

Основным достоинством данного метода является отсутствие изменений для хранения и получения последнего состояния объектов.

Недостаток — повышенное дублирование информации (к примеру, последнее состояние будет одинаково в обеих таблицах) и, соответственно, большой объем базы данных.

Если база данных разрабатывается с самого начала, то более логичным будет держать текущее состояние объектов и их историю в одной таблице. Тогда, получение состояния на текущий момент ничем не будет отличаться от получения состояния на заданную дату.

При использовании автонумеруемого поля в качестве идентификатора объекта, это поле придется вынести в отдельную таблицу ключей Objects, так как в таблице ObjectsHistory оно не будет уникальным:

create table[Objects]
(
  [Id]int not null identity primary key
  )
create table[ObjectsHistory]
(
  [object]int not null references[Objects]([Id]),
  [Code]varchar(120) not null,
  [Name]varchar(120) not null,
  [Note]varchar(250),
  ...
  [DateBegin]datetime not null default(getdate()),
  [DateEnd]datetime not null default('3000-01-01')
  constraint[ObjectHistory]primary key([object], [DateBegin])
  )

Первичный ключ в таблице истории состоит из двух полей: идентификатора объекта из таблицы ключей (Object) и даты начала действия истории объекта (DateBegin). Дата окончания действия истории (DateEnd) равна дате начала следующей истории объекта, и используется для более простых условий выборки.

При вставке объекта, необходимо вначале добавить запись в таблицу ключей и получить идентификатор объекта. Затем надо произвести запись в таблицу истории, где Object = идентификатор_объекта, DateBegin = текущая_дата, DateEnd = максимальная_дата.

При модификации объекта, нужно вставить измененную запись в таблицу истории, где Object = идентификатор_объекта, DateBegin = текущая_дата, DateEnd = максимальная_дата. При этом, у предыдущей записи с таким же идентификатором необходимо установить DateEnd = текущая_дата.

При удалении объекта, для последней записи с таким же идентификатором надо установить DateEnd = текущая_дата.

Выборка последнего состояния объектов производится с условием:

текущая_дата beetwen DateBegin and DateEnd

Условие для выборки на определенную дату:

заданная_дата beetwen DateBegin and DateEnd

Достоинством этого способа является его простота, а также однообразность хранения и получения текущего состояния и истории.

Недостатком будет более сложное получение текущего состояния. Информация по-прежнему остается избыточной — при изменении одного из свойств объекта, он копируется целиком.

Существует масса других способов хранения истории, начиная от простого журнала, в котором, при любом изменении записи в таблице, пишутся прежние значения полей, преобразованные в строку. Но далеко не все эти способы пригодны для легкого и быстрого получения состояния объектов на любую дату. Здесь были рассмотрены лишь наиболее простые и эффективные варианты представления истории, которые вполне подходят для практического применения.

Создание компонентов для работы с базами данных.

{ пример }
private
FDataLink: TFieldDataLink;

Примечание: Наш новый компонент будет иметь свойства DataField и DataSource, FDataLink также будет иметь собственные свойства DataField и Datasource.

{ пример }
published
property DataField: string
read   GetDataField
write  SetDataField;
property DataSource: TDataSource
read   GetDataSource
write  SetDataSource;

{ пример }
private
FDataLink: TFieldDataLink;
function GetDataField: String;
function GetDataSource: TDataSource;
procedure SetDataField(Const Value: string);
procedure SetDataSource(Value: TDataSource);
.
.
implementation
.
.
function TDBPanel.GetDataField: String;
begin
Result := FDataLink.FieldName;
end;
function TDBPanel.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBPanel.SetDataField(Const Value: string);
begin
FDataLink.FieldName := Value;
end;
procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
end;

{ пример }
private
.
.
procedure DataChange(Sender: TObject);
implementation
.
.
procedure TDBPanel.DataChange(Sender: TObject);
begin
if FDataLink.Field = nil then
Caption := '';
else
Caption := FDataLink.Field.AsString;
end;

{ пример }
public
constructor Create(AOwner: TComponent); override;
.
.
implementation
.
.
constructor TMyDBPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
end;

{ пример }
public
.
.
destructor Destroy; override;
.
.
implementation
.
.
destructor TDBPanel.Destroy;
begin
FDataLink.OnDataChange := nil;
FDataLink.Free;
inherited Destroy;
end;

Полный код компонента.

unit Mydbp;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, DB, DBTables;
type
  TDBPanel = class(TCustomPanel)
  private
    FDataLink: TFieldDataLink;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure DataChange(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property DataField: string
      read GetDataField
      write SetDataField;
    property DataSource: TdataSource
      read GetDataSource
      write SetDataSource;
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Samples', [TDBPanel]);
end;
function TDBPanel.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;
function TDBPanel.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;
procedure TDBPanel.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;
procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;
procedure TDBPanel.DataChange(Sender: TObject);
begin
  if FDataLink.Field = nil then
    Caption := ''
  else
    Caption := FDataLink.Field.AsString;
end;
constructor TDBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.OnDataChange := DataChange;
end;
destructor TDBPanel.Destroy;
begin
  FDataLink.Free;
  FDataLink.OnDataChange := nil;
  inherited Destroy;
end;
end.

Использование DB Controls без базы данных.

Оформил: DeeCo

Довольно часто на различных форумах задаются вопросы примерно такого характера: “Как мне красиво (как в DBGrid) отобразить содержимое списка структур?”, “Как можно вывести данные в DBGrid/DBControlGrid?”.

Конечно, существуют различные варианты ответа на каждый из этих вопросов. В первом случае можно попытаться создать потомка TDBGrid. Во втором – создать потомка TDataSource. Однако на мой взгляд, предпочтительнее (как в отношении предоставляемого программисту набора функций, так и в отношении применимости конкретного ответа для решения целого круга похожих задач) способ, применяемый обычно для разрешения более принципиальной задачи: как обеспечить единообразную работу с данными из имеющейся БД (DBase, Interbase, MS SQL Server и т.п.), и с другими, в частности, локальными данными программы?

Работа с базами данных при помощи стандартного набора компонентов Delphi строится по следующей схеме:

Видно, что наиболее полного единообразия работы с данными из БД и другими своими наборами данных можно достичь, создав для доступа к своим данным потомка TDataSet, поскольку именно этот класс отвечает за реальный доступ к данным.

Создание своего TDataSet – вовсе не такая сложная работа, как кажется на первый взгляд при просмотре исходного кода TDataSet и/или его стандартных потомков (например, TIBCustomDataSet). Основным препятствием является почти полное отсутствие документации от Borland. В поставляемом с Delphi простом примере TTextDataSet (потомка TDataSet, работающего с текстовым файлом на диске) прямо говорится: “Currently, the notes in this source file represent the only documentation on how to create a TDataSet implantation”, что в приблизительном переводе означает: “в настоящее время данный пример представляет собой единственную документацию по созданию реализации TDataSet”.

В данной работе я рассмотрю создание двух TDataSet. Один будет обеспечивать доступ в режиме “только чтение” к данным, вычисляемым “на лету” (в качестве примера выбрана таблица квадратов натуральных чисел от 1 до 20). Второй же позволит осуществлять доступ с возможностью модификации к списку структур вида (имя, адрес электронной почты). Любой промежуточный уровень функциональности легко может быть получен путем усечения функциональности второго примера.

В настоящей работе не рассматриваются:

Есть такое хорошее правило – прежде чем переходить к программированию, четко определить круг задач, которые обязательно должны быть решены. Давайте ему последуем. Я хочу создать потомка TDataSet, работающего с набором данных, содержащим два столбца: целое число и его квадрат. Для простоты этот набор данных будет содержать лишь 20 записей – для чисел от 1 до 20. Borland выдвигает еще одно требование: каждый потомок TDataSet должен поддерживать работу с закладками. Однако я позволю себе пока его проигнорировать – тем более, что и без этого получается практически вполне работоспособный класс. Желающие могут добавить в этот пример поддержку закладок, предварительно ознакомившись с механизмом закладок в следующем разделе.

О терминологии: в дальнейшем я буду использовать название TDataSet для обозначения программного кода и классов, тогда как под набором данных буду понимать сам набор данных, доступ к которому обеспечивает конкретный потомок TDataSet.

Чтобы создать потомка TDataSet, нужно понять, как TDataSet выполняет доступ к данным. Общедоступный (public) интерфейс полностью реализуется средствами самого TDataSet; на плечи конкретных потомков ложится лишь обеспечение средств коммуникации общедоступных методов с набором данных. В основном, коммуникация осуществляется методами InternalXXX, часть из которых в TDataSet объявлена пустыми, а часть – и вовсе абстрактными.

Эти методы можно разделить по их назначению на три группы: навигация (перемещение) по набору и чтение записи из БД в кэш-буфер (а также запись из кэш-буфера в набор данных), вставка/удаление записей, чтение/изменение значений полей записи, прочие методы (открытие и закрытие TDataSet, закладки, выделение и освобождение памяти).

Логика TDataSet никогда не работает со значениями полей записи прямо в наборе. Вместо этого вызовы GetRecord читают целиком записи, причем каждая из них заносится в свой кэш-буфер, и дальнейшие операции с полями каждой считанной записи выполняются в кэш-буфере. В TDataSet одновременно в памяти присутствуют, в общем случае, несколько буферов (свойство-массив Buffers). Помимо данных, считанных из БД, потомок TDataSet может размещать в буфере произвольную дополнительную служебную информацию.

Прежде, чем переходить к рассмотрению методов, я поясню одно из центральных для TDataSet понятий - понятие курсора.

Стандартный способ работы с БД таков, что целевая запись для таких воздействий, как удаление записи, изменение записи, вставка новой записи перед данной и т.п. не указывается явно при вызове соответствующей операции, а определяется предыдущими операциями. Соответственно, для хранения описания того места в наборе данных, которое будет являться целевым для следующей операции, необходимо ввести некую сущность – курсор.

Курсор - это произвольная информация, придающая смысл в каждый момент времени таким понятиям, как “текущая”, “следующая” и (для двунаправленных наборов данных) “предыдущая” запись. Позволю себе вольность пользоваться в отношении курсора фразой “перемещение курсора к некоторой записи”, подразумевая изменение составляющей курсор информации так, чтобы курсор указывал на эту запись.

Тот курсор, который определяет целевую позицию для действий, запрашиваемых у TDataSet сторонним кодом, я в дальнейшем буду называть логическим курсором. С логическим курсором в TDataSet связан буфер активной записи (свойство ActiveBuffer хранит адрес этого буфера).

Логический курсор никак не учитывает структуру набора данных, а потому сам по себе в общем случае недостаточен для эффективного указания на запись реального набора. Например, набор может представлять собой дерево, а коду TDataSet потомок, обеспечивающий работу с этим деревом, представляет его как последовательность вершин дерева, получающуюся при его обходе по некоторому правилу. В таком случае самое большее, что можно выяснить, зная значение логического курсора – это номер, под которым встретится данная вершина при таком обходе. Согласитесь, что не слишком удобно основывать работу с деревом на такой информации, ведь ее придется все время пересчитывать, например, в путь от корня дерева к данной вершине.

Поэтому потомкам TDataSet предлагается пользоваться своим собственным курсором, осведомленным о структуре набора. Назовем этот курсор физическим курсором. В простейшем случае, когда набор данных является простым массивом, на роль физического курсора может вполне сгодиться индекс записи в массиве.

В дальнейшем под курсором следует понимать логический курсор, если не оговорено обратное. Запись, на которую указывает логический курсор, я буду называть текущей записью.

Для поддержания согласованности логического курсора с физическим используется следующая техника: после вызова метода, от которого ожидается перемещение физического курсора на непредсказуемое расстояние от его текущего положение (например, при переходе на первую запись или поиске по закладке), вызывается метод Resync, считывающий в кэш-буферы запись, на которую теперь указывает физический курсор, а также несколько окружающих ее записей. Если же перемещение предсказуемо (как в случае метода MoveBy, вызываемого из Prior и Next), то читается лишь часть окружающих записей. Понятно, что в случае, когда вообще не ожидается никаких перемещений, никакие записи и не перечитываются.

Если потомку требуется переместить физический курсор вопреки ожиданиям TDataSet, необходимо оповестить его об этом вызовом CursorPosChanged. Такое оповещение обрабатывается не сразу, и, говоря откровенно, меня до сих пор гложут сомнения, не надежнее ли сразу вызывать Resync (хотя в таком случае можно проиграть в скорости, если после этого Resync будет вызван повторно).

Таким образом, в момент вызова методов InternalXXX логический курсор совпадает с физическим (от возможных сбоев этого соответствия в ходе выполнения закрытым кодом каких-либо внутренних операций спасает выполняющийся перед входом в InternalXXX вызов метода UpdateCursorPos), а после выхода из InternalXXX логический курсор опять-таки приводится в соответствие физическому.

UpdateCursorPos работает с буфером текущей записи: для помещения физического курсора на ту же запись, на которую указывает логический, он вызывает InternalSetToRecord, указав в качестве аргумента (буфера записи, к которой нужно перейти) буфер текущей записи (ActiveBuffer).

Единственное обнаруженное мной исключение из этого правила – метод InternalInsert (вызывающийся при вставке записи), перед вызовом которого не выполняется UpdateCursorPos, из-за чего приходится искать способ переместить физический курсор на ту же запись, на которую указывает логический, при этом не пользуясь private-членами TDataSet). Подробнее об этом – в следующем разделе.

При открытии (инициализации) логического курсора (TDataSet.OpenCursor, вызывается при TDataSet.Active:=true и по выходу из режима дизайнера) вызывается метод InternalOpen. Он должен сформировать список определений полей FieldDefs и, если свойство DefaultFields равно True, создать на их базе список полей Fields. Он также должен связать поля из списка Fields с полями набора данных и установить физический курсор в позицию перед первой записью. Кроме того, если до начала манипулирования содержащимися в наборе данными нужно предпринять какие-либо действия (например, установить соединение с удаленным сервером), их также следует выполнить в этом методе.

InternalOpen может вызываться не только из OpenCursor. Запрос на формирование списка FieldDefs может поступить и отдельно: в этом случае вызывается метод InitFieldDefs, который может вызывать InternalInitFieldDefs (последний должен инициализировать FieldDefs).

Для проверки того, что логический курсор открыт (т.е. что набор готов предоставить доступ к своим данным), вызывается функция IsCursorOpen, возвращающая True или False. Ясно, что до выполнения Open она должна возвращать False, а после Open и до последующего Close – True.

Для закрытия набора данных (TDataSet.Close) вызывается метод InternalClose, назначение которого симметрично InternalOpen: если DefaultFields установлено в True, то уничтожить список полей Fields (в этом случае они были созданы самим потомком в ходе выполнения InternalOpen); также, в случае необходимости, выполнить такие действия, как разрыв соединения с сервером БД.

Для навигации (перемещения логического курсора) по набору применяются общедоступные методы First, Prior, Next и Last.

Метод First вызывает метод InternalFirst, который должен установить физический курсор на позицию перед первой записью в наборе. После этого First выполняет серию вызовов GetNextRecord (а те, в конечном счете, GetRecord) для чтения в кэш-буферы следующей (т.е. первой) записи набора и нескольких последующих записей. Затем при помощи вызова DataEvent генерируется уведомление об изменении данных в кэш-буферах.

Зачем нужно устанавливать курсор на позицию перед первой записью, а потом читать следующую запись? Почему бы просто не поместить курсор сразу на первую запись? Дело, возможно, в том, что если для позиционирования на первую запись необходимо переоткрытие набора (например, в однонаправленных наборах), то эта обязанность возлагается на InternalFirst. То есть для помещения курсора на первую запись InternalFirst должен был бы переоткрыть набор и выполнить переход к следующей записи. По-видимому, команда разработчиков Borland решила, что будет лучше, если все команды навигации по записям будут подаваться из находящегося в базовом классе TDataSet слоя абстрактной логики, а не из методов, отвечающих за конкретную реализацию доступа к данным (таких, как InternalFirst). Таким образом, работа IntrnalFirst должна в такой ситуации завершаться переоткрытием (а после этой операции курсор, как уже говорилось, находится перед первой записью).

Аналогично, InternalLast должен устанавливать физический курсор в позицию, находящуюся за последней записью БД (это уже, видимо, просто для единообразия).

Методы Prior и Next апеллируют к одному и тому же методу GetRecord. Последний многофункционален: он должен проверить, не выйдет ли позиция курсора при выполнении операции за пределы БД, изменить позицию физического курсора, считать из набора в буфер записи, переданный в качестве аргумента, данные записи, ставшей текущей, и (в зависимости от параметров вызова) в случае ошибки возбудить исключение.

Когда необходимо прочитать значение некоторого поля текущей записи, вызывается GetFieldData, в который передается ссылка на соответствующий нужному полю объект TField и адрес буфера, содержащего запись. GetFieldData – перегруженный метод, но фактическое извлечение значения поля из буфера записи в так называемом Native-формате (его мы рассмотрим далее) осуществляет лишь одна из его версий (остальные версии в конечном счете просто вызывают именно ее).

Кстати, существует и еще один способ позиционирования физического курсора: метод InternalSetToRecord предназначен для установки курсора на запись, содержимое которой находится в переданном в качестве аргумента буфере (ранее оно было считано в этот буфер методом GetRecord).

Для выделения памяти под новый буфер вызывается метод AllocRecordBuffer, для освобождения занятой под буфер памяти – FreeRecordBuffer. Надо заметить, что TDataSet может повторно использовать уже выделенный однажды буфер для хранения другой записи. Обработку вытеснения записи из буфера при таком повторном использовании можно поместить туда же, куда и действия по подготовке буфера перед помещением туда записи – в InitRecordBuffer. Этот метод вызывается перед каждым помещением в буфер какой-либо записи.

Редактирование данных, в т.ч. добавление и удаление записей, становится возможно, когда метод GetCanModify возвращает True. Процессы, происходящие при редактировании, будут рассмотрены в следующем разделе, поэтому пока мы считаем, что GetCanModify всегда возвращает False.

Метод InternalHandleException служит для обработки возможных исключений, возникающих при чтении объекта из потока. Насколько мне удалось понять из исходных текстов потомков TDataSet, предлагаемых Borland, хорошим тоном является такая его реализация: Application.HandleException(Self).

Метод IsSequenced должен возвращать True, если в наборе каждую запись можно однозначно сопоставить с ее порядковым номером (т.е. числом, показывающим, какой по счету окажется запись при последовательном переборе всех записей, начиная с первой).

Помимо этих методов, в работе с данными может участвовать еще несколько семейств методов, предназначенных для расширения возможностей TDataSet. Одно из них - работа с закладками - как я уже говорил, будет рассмотрено в следующем разделе. Поддержка остальных не является обязательной (см. также перечень не рассматриваемых здесь функций в конце раздела “Область применения”). Однако три из них стоит реализовать, иначе довольно некрасиво смотрится полоса прокрутки в DBGrid и подобных ему элементах управления, а клиенты теряют возможность простого позиционирования на запись по ее номеру.

Последние два метода фактически являются реализацией свойства RecNo.

Два слова о Native-формате данных: детально мы его обсудим в следующем разделе, пока же – основное. Извлеченные из записи данные следует возвращать в особом формате (Native), своем для каждого типа поля. В нашем примере используются только поля типа ftInteger, для которых Native-формат представляет собой 4-байтовое целое число со знаком, т.е. значение типа integer. (см. чтение в методе GetFieldData).

unit DataSet0;
//Простой Read-Only BiDirectional DataSet в виде таблицы
// квадратов целых чисел (два поля – число и его квадрат)
interface
uses DB, Classes {для TComponent};
type
  TMyDataSet = class(TDataset)
  protected
    procedure InternalHandleException; override;
    // Инициализация/деинициализация курсора
    procedure InternalInitFieldDefs; override;
    procedure InternalOpen; override;
    function IsCursorOpen: Boolean; override;
    procedure InternalClose; override;
    // Выборка
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean):
      TGetResult; override;
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure InternalInitRecord(Buffer: PChar); override;
    // Навигация
    procedure InternalFirst; override;
    procedure InternalLast; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    // Разрешение доступа
    function GetCanModify: Boolean; override;
    // Необязательные методы
    function GetRecordCount: Integer; override;
    //Везде в данном коде, где используется RecordCount, можно было бы просто
    //написать List.Count. Реализовывать GetRecordCount не обязательно.
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
    //Здесь номер записи считается от 1
  public
    // Чтение поля
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
    // Создание/уничтожение
    constructor Create(AOwner: TComponent); override;
  private
    FIsOpen: boolean;
    FCursor: integer;
  end;
  TRecordData = record
    //Собственно копия записи – по замыслу, она должна считываться из БД
    Number, Square: integer;
  end;
  TRecordBuffer = record //Формат буфера, хранящего запись: данные записи +
    //служебная информация
    RecordData: TRecordData;
    RecordIndex: integer; //Номер записи, считая от 1
  end;
  PRecordBuffer = ^TRecordBuffer;
implementation
procedure TMyDataSet.InternalHandleException;
begin
  Application.HandleException(Self)
end;
procedure TMyDataSet.InternalInitFieldDefs;
begin
  FieldDefs.Clear;
  with FieldDefs.AddFieldDef do
  begin
    DataType := ftInteger;
    FieldNo := 1;
    Name := 'Число';
  end;
  with FieldDefs.AddFieldDef do
  begin
    DataType := ftInteger;
    FieldNo := 2;
    Name := 'Квадрат';
  end;
end;
procedure TMyDataSet.InternalOpen;
begin
  InternalInitFieldDefs;
  if DefaultFields then
    CreateFields;
  BindFields(true); //Привязываем поля к БД
  FIsOpen := true;
  FCursor := 0;
end;
function TMyDataSet.IsCursorOpen: Boolean;
begin
  result := FIsOpen
end;
procedure TMyDataSet.InternalClose;
begin
  BindFields(False); //Отвязываем поля
  if DefaultFields then
    DestroyFields;
  FIsOpen := false;
end;
procedure TMyDataSet.InternalFirst;
begin
  FCursor := 0
end;
procedure TMyDataSet.InternalLast;
begin
  FCursor := RecordCount + 1
end;
function TMyDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  result := grOK;
  case GetMode of
    gmPrior: if FCursor <= 1 then
        result := grBOF
      else
        Dec(FCursor);
    gmNext: if FCursor >= RecordCount then
        result := grEOF
      else
        Inc(FCursor);
    gmCurrent: if (FCursor < 1) or (FCursor > RecordCount) then
        Result := grError;
  end;
  if result = grOK then
    with PRecordBuffer(Buffer)^ do
    begin
      RecordData.Number := FCursor;
      RecordData.Square := sqr(RecordData.Number);
      RecordIndex := FCursor;
    end;
  if (result = grError) and DoCheck then
    DatabaseError('Error in GetRecord()');
end;
function TMyDataSet.GetRecordCount: Integer;
begin
  Result := 20
end;
procedure TMyDataSet.SetRecNo(Value: Integer);
begin
  if (Value < 1) or (Value >= RecordCount + 1) then
    exit;
  FCursor := Value;
  Resync([])
end;
//Мне не пришло в голову более умного средства синхронизации логического
// курсора с физическим, чем выполнение Resync (ресинхронизация – сброс
// логического курсора и последующее чтение записей, окружающих
// физический курсор)
function TMyDataSet.GetRecNo: Integer;
//Возвращает номер записи, соответствующей активному в данный момент буферу
begin
  Result := PRecordBuffer(ActiveBuffer)^.RecordIndex
end;
procedure TMyDataSet.InternalSetToRecord(Buffer: PChar);
begin
  FCursor := PRecordBuffer(Buffer)^.RecordIndex
end;
function TMyDataSet.AllocRecordBuffer: PChar;
begin
  GetMem(result, sizeof(TRecordBuffer))
end;
procedure TMyDataSet.FreeRecordBuffer(var Buffer: PChar);
begin
  FreeMem(Buffer, sizeof(TRecordBuffer))
end;
procedure TMyDataSet.InternalInitRecord(Buffer: PChar);
begin
  inherited; //Нам не нужна какая-то особая инициализация буфера записи
  // до чтения туда фактической записи
end;
function TMyDataSet.GetCanModify: Boolean;
begin
  result := false
end;
function TMyDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
begin
  result := true;
  case Field.FieldNo of
    1: PInteger(Buffer)^ := PRecordBuffer(ActiveBuffer)^.RecordData.Number;
    2: PInteger(Buffer)^ := PRecordBuffer(ActiveBuffer)^.RecordData.Square;
  else
    result := false;
  end;
end;
constructor TMyDataSet.Create(AOwner: TComponent);
begin
  inherited;
  FIsOpen := false;
end;
end.

Для проверки работы класса TMyDataSet можно использовать следующий тестовый проект:

program Dataset;
uses Forms, DB, DBGrids, DBCtrls, Controls, DataSet0;
var
  F: TForm;
  DS: TDataSource;
  MyDataSet: TMyDataSet;
begin
  Application.Initialize;
  Application.CreateForm(TForm, F);
  F.Width := 300;
  F.Height := 300;
  F.Position := poDesktopCenter;
  MyDataSet := TMyDataSet.Create(F);
  MyDataSet.Open;
  DS := TDataSource.Create(F);
  DS.DataSet := MyDataSet;
  with TDBNavigator.Create(F) do
  begin
    Parent := F;
    Align := alTop;
    DataSource := DS
  end;
  with TDBGrid.Create(F) do
  begin
    Parent := F;
    Align := alClient;
    DataSource := DS
  end;
  Application.Run;
end.

Разумеется, чаще возникают ситуации, когда необходимо обеспечить возможность редактирования данных, в т.ч. удаления записей и добавления новых. Определенные сложности при этом могут возникать лишь при добавлении новых записей, в то время как редактирование и удаление достаточно тривиальны.

Рассмотрим более сложный и более приближенный к реальности пример потомка TDataSet. Наш класс TMyDataSet будет предоставлять доступ для чтения/изменения/удаления/добавления записей в адресную книгу, представляющую собой список (обычный TList), содержащий указатели на записи, состоящие из двух строковых компонентов: имени и электронного адреса. Кроме того, TMyDataSet будет поддерживать работу с закладками.

Итак, какие действия предпринимает TDataSet при редактировании, добавлении и удалении записей?

Самая простая операция – удаление. Вызов общедоступного метода Delete приводит (если TDataSet не находится в состоянии вставки записи, в противном случае Delete просто вызывает Cancel) к вызову InternalDelete, на который возлагается обязанность удалить запись из набора. Работа завершается вызовом Resync, так что InternalDelete может поместить физический курсор на любую запись по своему усмотрению.

Что касается редактирования, то можно выделить два его вида: обычное редактирование записи (состояние dsEdit), которое я и буду в дальнейшем называть редактированием, и вставка записи (dsInsert).

Для начала редактирования вызывается метод Edit. Он, в свою очередь, вызывает метод InternalEdit. В большинстве ситуаций никаких действий в InternalEdit можно не предпринимать – TDataSet переведет объект в состояние dsEdit, особым образом обработает вычисляемые (calculated) поля, выдаст сообщение об изменении записи и т.д. Для начала вставки записи вызовается Insert или Append. Как в состоянии dsInsert, так и в dsEdit TDataSet позволяет вносить в запись изменения.

Выводится из этих состояний TDataSet также одинаковыми способами. Их два: вызов метода Post (подтверждение изменений – и вставки, если мы находимся в состоянии dsInsert) или метода Cancel (отмена изменений/вставки). Первый из них вызывает InternalPost, второй – InternalCancel. Отметим, что перед вызовом каждого из них осуществляется вызов UpdateCursorPos – а это означает, что физический курсор будет совпадать с логическим. Методы Post и Cancel могут быть вызваны не только напрямую сторонним кодом, но и из других методов TDataSet: так, при попытке, пока TDataSet находится в состоянии редактирования (dsEdit) или вставки (dsInsert), переместить логический курсор на другую запись, операция вставки или редактирования будет либо отменена, либо подтверждена (в зависимости от того, внесены ли в запись изменения). Логика TDataSet полностью возлагает реализацию добавления/удаления/редактирования записей на Internal-методы; в частности, именно они определяют, в какую позицию набора будет при вставке помещаться вставляемая запись, будет ли она добавлена сразу (а при вызове InternalCancel – удалена) или будет существовать только в виде буфера (а физически добавляться при вызове InternalPost).

Серьезное обсуждение операции вставки невозможно без знакомства с аппаратом закладок.

Закладка (bookmark) – это некоторая информация, идентифицирующая положение записи в наборе данных. Предпочтительно представлять закладку ANSI-строкой символов (т.е. последовательностью ненулевых символов, завершающейся нулевым), т.к. клиент может пытаться читать ее из свойства Bookmark методом GetBookmarkStr именно как ANSI-строку (в примере от Borland закладка представляется 4-байтовым адресом записи, что, безусловно, неправильно, т.к. адрес может содержать нулевые байты). Свойство Bookmark возвращает закладку, соответствующую текущей записи. Впоследствии с помощью этой закладки можно очень быстро сделать текущей соответствующую ей запись. Закладка всегда указывает на одну и ту же запись, вне независимости от изменения положения этой записи в наборе.

Если задача потомка TDataSet – обмен данными с каким-либо сервером БД, то, скорее всего, сервер уже снабжен поддержкой закладок, и можно просто перенаправлять все запросы ему.

Кроме собственно закладки, каждой записи соответствует поле так называемого флага закладок. Записи соответствует ровно один флаг закладки, как и ровно одна закладка. Флаг закладки предназначен для того, чтобы логика TDataSet могла отличать одни типы записей от других. Помимо нормального флага bfCurrent, определены следующие значения:

Для клиента (т.е. внешнего по отношению к потомку TDataSet кода) работа с закладками сводится к двум операциям: чтению закладки для текущей записи и перемещению к записи, для которой известна закладка. Этим действиям соответствуют два метода TDataSet: GetBookmarkData и InternalGotoBookmark. Есть, впрочем, и третий метод, SetBookmarkData, служащий для изменения значения закладки текущей записи. Замена закладки исключительно плохо документирована. Разбор исходного текста класса TDataSet показывает, что код TDataSet вызывает SetBookmarkData в одном-единственном случае – перед вызовом InternalInsert новой записи приписывается та же закладка, что и предыдущей активной (если только вставляемая запись не окажется первой и единственной в наборе).

Смысл этого дублирования мне (после просмотра примера от Borland) видится таким: так как значение физического курсора, соответствующее предыдущей активной записи, неизвестно, а добавленная в набор данных запись может до вызова Post быть “висячей” (а значит, также не иметь соответствующего ей значения физического курсора), то предлагается вместо перехода на запись использовать переход на закладку. При этом до вызова Post предыдущая активная запись и новая запись имеют одинаковые закладки. Никакой коллизии здесь нет – при попытке получить закладку вставленной, но не добавленной в набор записи (у нее флаг закладки равен bfInserted, bfEOF или bfBOF), возвращается пустая строка (т.к. метод BookmarkAvailable может вернуть True лишь для записей с флагом закладки bfCurrent). То есть, с точки зрения внешнего по отношению к TDataSet кода, новая запись закладки не имеет. Это, кстати, следует учитывать в реализации поиска записи по закладке: поиск нужно проводить лишь по записям с флагом закладки bfCurrent.

При обработке InternalPost закладку у вставляемой записи нужно изменить на такую, которая позволит однозначно эту запись идентифицировать – ведь теперь ее флаг закладки равен bfCurrent, и если оставить старое значение закладки, то в этом наборе будут присутствовать несколько записей с одинаковыми закладками, но разными значениями физического курсора.

Как только мы начинаем реализовывать операцию вставки, сразу же встает важный вопрос: в какую позицию набора помещать добавляемую запись?

Вообще говоря, в TDataSet существует два способа добавления записи. Это методы Insert и Append (оба в итоге вызывают InternalInsert) – их назначение описано в справочной службе. Для обоих методов жестко определено лишь одно требование: логический курсор должен переместиться на добавленную запись. О том, в какую именно позицию вставляется новая запись каждым из методов, можно прочитать в справочной системе Delphi (каждая конкретная БД поступает по-своему).

В принципе, можно сделать так, чтобы не только по Append, но и по Insert записи всегда добавлялись в конец набора. Со вставкой в конец проблем обычно не возникает, т.к. в этом случае приходится перемещать физический и логический курсоры, а значит, начальное значение физического курсора можно не принимать во внимание. Добавление в конец, однако, не всегда приемлемо, и вдобавок вызывает неприятные визуальный эффект (особенно если мы одновременно обозреваем несколько соседних записей, как в DBControlGrid или DBGrid): как только курсор уходит с записи, она “прыгает” из зоны видимости в конец набора.

Поэтому имеет смысл задаться целью вставить запись именно в то место TDataSet, на которое при вызове Insert указывает логический курсор. Везде в дальнейшем предполагается, что вставка новой записи осуществляется как раз согласно этому правилу.

Сама по себе вставка проблемой не является и в этом случае. Проблема – в том, как корректно обрабатывать возникающую “виртуальную” запись, реально не существующую в наборе? А именно, как правильно обрабатывать команды на перемещение курсора на эту запись, или между ней, предыдущей и следующей записями.

Перемещение физического курсора может произойти при вызове одного из следующих методов: InternalFirst, InternalLast, GetRecord, SetRecNo, InternalSetToRecord и InternalGotoBookmark. Пока TDataSet находится в состоянии dsInsert – то есть до отмены или подтверждения вставки записи – один из этих методов может быть вызван только при вызове методов UpdateCursorPos, Resync, SetBufferCount или при записи в свойство Bookmark. В других случаях TDataSet предварительно выходит из состояния редактирования. Например, попытка выполнить метод First приведет еще до вызова InternalFirst к вызову либо Cancel, либо Post.

С SetRecNo есть небольшая тонкость: непонятно, имеет ли вставленная запись номер до того, как она будет включена в набор. Я буду предполагать, что не имеет. В противном случае пришлось бы в GetRecNo и SetRecNo сравнивать номер записи с номером вставленной записи и перемещение курсора производить в зависимости от результата. А раз не имеет, то работа SetRecNo не зависит от виртуальных записей.

Ясно, что методы InternalSetToRecord и InternalGotoBookmark для любой записи в наборе данных, кроме вставленной, будут работать так же хорошо, как работали без этой виртуальной записи (т.к. целевая запись – единственная идентифицируемая переданными в метод аргументами запись, реально существующая в наборе). То есть опасность может представлять лишь попытка перейти на саму редактируемую запись, и именно этот случай мы должны распознавать. Но куда же в такой ситуации помещать курсор?

Вызов InternalGotoBookmark приведет, т.к. закладка вставленной записи дублирует закладку какой-то уже имеющейся, к переходу на эту уже имеющуюся запись. Естественно ожидать, что так же должна себя вести и InternalSetToRecord. Для этого есть и более существенные основания – они будут рассмотрены чуть позже при анализе методов GetNextRecord и GetPriorRecord. Есть несколько способов добиться такого поведения InternalSetToRecord, их мы тоже рассмотрим позже.

Для UpdateCursorPos принципиально, для чего (перед какой операцией) осуществляется позиционирование курсора. Этот метод вызывается при ошибках перед Resync, а также: в Refresh, Cancel, AddRecord, Edit, Post, Delete. Вызов Edit в состоянии dsInsert игнорируется, вызов Delete вырождается в обращение к Cancel, а вызов AddRecord приводит еще до UpdateCursorPos к выходу из режима редактирования. Вызов перед Resync, так же, как и внутри Refresh, производится для того, чтобы Resync прочитал записи именно вокруг текущей. Вызов в Post дает InternalPost знать, в какое место набора данных вставляется запись. Вызов в Cancel позволяет InternalCancel сделать, например, вывод о том, какую запись нужно сделать текущей после отмены вставки.

С учетом этого для UpdateCursorPos курсор вполне корректно устанавливать на запись, перед которой осуществляется вставка. Действительно, в InternalPost легко по значению курсора, указывающему на следующую запись, понять, в какое место в наборе нужно поместить вставленную запись (отодвинув последующие): именно на это место. InternalCancel можно не перекрывать. Тогда после “вычеркивания” вставленной записи текущей станет запись, следующая за ней, что выглядит вполне логично. По поводу Resync см. замечания далее.

Как обеспечить правильную работу SetBufferCount? Если взглянуть на код этого метода, видно, что опасны лишь два ситуации:

Для метода GetNextRecord, вызывающего SetCurrentRecord, опасен случай, когда самый последний буфер содержит вставленную запись. Ясно, что в качестве “следующей” нужно прочитать запись, находящуюся в наборе за этой записью.

Для метода GetPriorRecord, также обращающегося к SetCurrentRecord, опасен случай, когда вставленная запись находится в первом буфере. Нужно прочитать запись, находящуюся в наборе перед вставленной.

Понятно, что на какую бы реально существующую в наборе запись не устанавливал физический курсор метод InternalSetToRecord, она не может находиться одновременно и прямо перед записью, следующей за вставленной, и сразу за записью, за которой следует вставленная.

В GetNextRecord имеется следующий код:

if (State = dsInsert) and (FCurrentRecord = FActiveRecord) and
  (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
  GetMode := gmCurrent;

Если бы вместо bfCurrent стояло fbInserted, эти строки можно было бы понять так: если TDataSet находится в состоянии редактирования, и имеет место случай (1), причем вставленная запись пока отсутствует в наборе, то читается не запись, следующая за той, на которую указывает физический курсор, а именно та, на которую физический курсор и указывает. Следовательно, здесь код TDataSet рассчитывает, что InternalSetToRecord при попытке установки физического курсора на вставленную запись будет устанавливать его на следующую за ней запись.

Однако в исходных текстах TDataSet написано именно bfCurrent, что очень меня удивляет. Возможно, я чего-то не понимаю, но не исключено, что это ошибка разработчиков из Borland. Последствия, к которым приводит эта недоработка, читатель легко может увидеть сам: нужно поместить на форму DBGrid с Align=alClient и DBNavigator с Align=alTop. Высота формы должна быть небольшой, чтобы в DBGrid была видна лишь одна запись БД. Если теперь пользователь добавит запись (щелчок по кнопке из DBNavigator) перед этой видимой записью, а затем увеличит высоту окна, то в DBGrid отобразятся не все записи, следующие за вставленной: не будет той записи, перед которой мы производим вставку. Конечно, необходимо для демонстрации связать с сеткой потомок TDataSet, позволяющий производить вставку в произвольное место набора – например, TADOTable.

Дело в том, что при увеличении высоты DBGrid, последний автоматически увеличит количество буферов в используемом TDataSet, чтобы иметь по одному буферу для каждой из одновременно отображаемых в сетке записей. Для этого будет вызван SetBufferCount, который забудет прочитать одну из записей (ту, перед которой происходит вставка).

Кстати, подобный эффект можно увидеть, если между созданием потомка TDataSet и отображением DBGrid выполнить у TDataSet метод Insert – одна из записей не будет показана в DBGrid.

А вот если бы вместо проверки на bfCurrent выполнялась проверка на bfInserted, все было бы в порядке.

Из этого следует, что идеально правильной работы, возможно, удастся добиться лишь таким образом: записи следует добавлять в набор сразу же при вызове InternalInsert, но не устанавливать для них флаг закладки bfCurrent вместо bfInserted (иначе GetNextRecord будет работать с ошибками в силу все того же фрагмента кода).

Проведенная мною небольшая серия испытаний пока не выявила противопоказаний к такому решению. Однако есть некоторые сомнения – все-таки это вмешательство в обычную схему работы TDataSet. Желающие могут провести самостоятельные эксперименты. Я сделал так: код, добавляющий запись, перенес из InternalPost в InternalInsert, в internalPost действия в состоянии dsInsert сделал такими же, как и в dsEdit, а InternalCancel просто свел к вызову InternalDelete.

Далее в этой работе я все-таки буду придерживаться обычной схемы, несмотря на содержащиеся в ней ошибки. Лучше уж ошибаться вместе со всеми, чем в гордом одиночестве.

Метод Resync, вообще говоря, также работает неправильно, но относительно него в файлах справки Delphi есть предупреждение, гласящее, что Resync предназначен для внутреннего использования и не должен вызываться извне TDataSet напрямую. Сам же TDataSet никогда и не вызывает Resync в состоянии dsInsert. Остается надеяться, что потребители нашего потомка TDataSet учтут предупреждение.

Итак, как же реализовать InternalSetToRecord?

Сложность заключается в том, что к моменту вызова InternalInsert метод UpdateCursorPos не был вызван, а буфер активной ранее записи уже перезаписан вызовом InternalInitRecord, так что, даже если мы вызовем UpdateCursorPos, он попытается вызвать InternalSetToRecord для перемещения физического курсора на запись, соответствующую данному буферу – но буфер-то теперь содержит новую информацию.

Попробуем придумать, как можно реализовать InternalSetToRecord таким образом, чтобы он успешно определял, где именно находится эта новая запись.

Есть два пути. Начнем с простого. Будем хранить в буфере записи значение физического курсора, при котором он (курсор) указывает на эту запись.

В результате выполнения Post или Delete значения курсора, соответствующие записям, считанным в буферы, могут отличаться от значений, сохраненных в этих же буферах, но последующий вызов Resync (которым завершаются Post и Delete) прочитает эти записи заново, устранив расхождение.

Чтобы определить, какая запись была активной до вызова Insert, можно перекрыть метод DoBeforeInsert, который вызывается еще до изменения активного буфера, и в нем тем или иным образом запомнить значение физического курсора. Между вызовами DoBeforeInsert и InternalInsert не выполняется никаких действий, изменяющих положение физического курсора. В случае Append это не так, но тут нам может помочь другое. Если на момент вызова Insert набор не содержит записей, то после InitRecord для новой записи ставится флаг закладки bfBOF. Если вызван Append, ставится флаг fbEOF. В остальных случаях флаг остается таким, каким его сформировал InitRecord, то есть fbInserted. Поэтому при вызове InternalInsert можно поступить так: если флаг не равен bfInserted, то установить значение физического курсора, хранимое в буфере активной записи, так, как это по смыслу нужно для выполнения Append, в противном же случае – равным значению, выясненному в DoBeforeInsert. Конечно, это означает привязку к последовательности вызовов в логике TDataSet, и есть опасность несовместимости с грядущими новыми версиями VCL.

Второй вариант – его использует Borland в своих потомках TDataSet – заключается в сведении InternalSetToRecord к вызову InternalGotoBookmark. Модификация этого решения используется в компоненте TRxMemoryData из RX Library.

Основания таковы. Если запись имеет флаг закладки bfCurrent, то у нее есть закладка; если флаг bfInserted, то, хотя BookmarkAvailable для нее вернет False, значение закладки все-таки установлено и совпадает с закладкой записи, “отодвигаемой” при вставке; если bfBOF или bfEOF, то нам вообще беспокоиться не о чем – TDataSet вызовет не InternalSetToRecord, а InternalFirst или InternalLast.

В таком подходе есть один недостаток: когда мы отодвигаем одну из записей набора, чтобы вставить новую, закладки записей не должны изменяться – иначе весь механизм закладок окажется лишенным смысла, т.к. клиент не сможет перейти по ранее сохраненной закладке на соответствовавшую ей в момент получения закладки запись. С другой стороны, значения физического курсора, соответствующие отодвигаемым записям, должны измениться. Следовательно, есть два пути. Можно в паре с каждой закладкой хранить информацию (скрытую от внешнего по отношению к нашему потомку TDataSet кода), позволяющую вычислить значение физического курсора. В таком случае при добавлении/удалении записей нужно изменять внутреннее преставление по меньшей мере нескольких, а то и всех, закладок (в зависимости от того, насколько эффективные алгоритмы использовать и какую информацию хранить).

С другой стороны, в случае, если операций вставки производится существенно больше, чем операций поиска по закладке (путем присваивания свойству Bookmark, т.е. не считая вызовов InternalSetToRecord), может оказаться выгоднее (и уж точно – проще) искать записи последовательным перебором, а InternalSetToRecord реализовать так, как описано ранее (DoBeforeInsert и InternalInsert).

Разумеется, дилемма отпадает, если вставку всех записей производить как добавление в конец набора – тогда можно просто принять в качестве закладки значение физического курсора.

Чуть не забыл! Insert и Append – не единственные методы для вставки записей. Если имеется буфер записи, в который уже записаны значения полей, то можно добавить в набор запись с такими значениями полей вызовом InsertRecord. Этот метод обращается к AddRecord, а тот, в свою очередь, к InternalInsertRecord. Такой способ добавления записи тоже нужно обрабатывать.

Приведу обещанное описание Native-формата данных:

Когда я только начинал писать эту статью, основной моей целью было показать, что интерфейс между DBGrid и, например, массивом можно наладить достаточно легко. Но, возможно, для таких простых ситуаций имеет смысл пойти дальше и разработать свой собственный интерфейс как надстройку над классом TDataSet, для обеспечения функционирования которого достаточно будет перекрыть всего десяток методов. Последовав советам, я решил вместо перекрывания методов ввести систему событий.

С учетом сказанного, второй пример будет состоять из двух частей: TMyDataSet – переходник, обеспечивающий упрощенное взаимодействие с методами TDataSet, используя обычный для Delphi механизм событий, и TMyData – класс, содержащий собственно адресную книгу и методы работы с ней, которые и назначаются в качестве реакций на события TMyDataSet.

Эту схему событий я решил основать на принципе обращения к записям по их последовательным номерам, отсчитываемым от единицы. На мой взгляд, это вполне оправданно, т.к. я адаптирую интерфейс TDataSet именно к простым наборам данных (таким, как списки или массивы), а для существенно более сложных наборов целесообразнее, возможно, работать с обычным интерфейсом TDataSet.

Вот введенные мной события:

FPerformOpenConnection: procedure(DS: TDataSet) of object;
-Установление соединения с носителем набора данных
FPerformCloseConnection: procedure(DS: TDataSet) of object;
-Разрыв соединения
FPerformFillFieldDefs: procedure(FieldDefsRef: TFieldDefs) of object;
-Формирование списка определений полей(аргумент - объект - список полей)
FPerformGetFieldData: procedure(Index: integer; Field: TField; out Data)
of object;
-Чтение значения поля Field записи с номером Index
FPerformSetFieldData: procedure(Index: integer; Field: TField; var Data)
of object;
-Изменение значения поля
PerformGetCanModify: function: boolean of object;
-Определение того, можно ли вносить изменения в набор
FPerformGetRecordCount: function: integer of object;
-Определение количества записей в наборе
FPerformDeleteRecord: procedure(Index: integer) of object;
-Удаление записи
FPerformClearFields: procedure(Index: integer) of object;
-Очистка полей записи
FPerformCreateFloatingRecord: function(SourceIndex: integer): integer
of object;
-Создание “плавающей” записи.Передается номер записи, значения полей
которой нужно скопировать в “плавающую”(0, если копировать ничего
  не нужно)
FPerformFreeFloatingRecord: procedure(Index: integer) of object;
-Удаление “плавающей” записи с номером Index
FPerformDefloatRecord: procedure(FlIndex, DestIndex: integer;
  DefloatMode: TDefloatMode) of object;
-Помещение “плавающей” записи с номером Index в набор в позицию, занимаемую
записью DestIndex.DefloatMode указывает, вставляется ли “плавающая”
запись вместо DestIndex или перед ней
FPerformGetBookmarkSize: function: integer of object;
-Определение размера закладки
FPerformGetBookmark: function(Index: integer): TBookmarkStr of object;
-Опрос закладки
FPerformSetBookmark: procedure(Index: integer; NewBookmark: TBookmarkStr) of
object;
-Установка закладки для записи
FPerformFindBookmark: function(Bookmark: TBookmarkStr): integer of object;
-Переход к записи по закладке

Работа осуществляется таким образом: класс, поставляющий обработчики событий (будем называть его поставщиком), берет на себя хранение данных и закладок, а также операции с записями по их номерам. Предлагаемый же потомок TDataSet отвечает за поддержание взаимно однозначного соответствия записей и их номеров и за перевод обычных последовательностей операций TDataSet в вызовы вышеперечисленных событий.

Особо следует пояснить понятие “плавающей” записи. Предполагается, что поставщик не считывает записи набора в какие-то свои кэш-буферы, а читает содержимое полей прямо из набора. В случае чтения это работает, но в случае редактирования записей производимые изменения следует где-то накапливать, то есть в этой ситуации временное хранилище создавать придется. Однако, есть способ упростить эту операцию. Хранилище можно (так как одновременно при таком подходе будет использоваться не более одного хранилища) реализовать в виде, например, какого-то зарезервированного элемента набора (массива, списка). Соответственно, можно сделать единообразным доступ как к записям набора, так и к этому хранилищу. Когда поступает запрос на начало редактирования существующей записи или на добавление новой, у поставщика запрашивается создание такого хранилища. В ответ поставщик возвращает число – это может быть, например, номер зарезервированной записи, или вообще любой номер такой, что в дальнейшем поставщик будет в состоянии понять, что этот номер относится именно к хранилищу. Таким образом, роль хранилища с точки зрения нашего потомка TDataSet будет играть запись с этим номером – ее мы и назовем “плавающей записью”.

Затем происходит либо очистка полей плавающей записи, либо (в случае редактирования существующей записи) копирование в эти поля значений полей исходной записи. В дальнейшем, пока изменения не будут подтверждены или отменены, вместо чтения и записи полей исходной будет производиться чтение и запись полей “плавающей”. При отмене изменений у поставщика запрашивается освобождение “плавающей” записи, при подтверждении – вызывается FPerformDefloatRecord (см. описание этого события).

Отмечу небольшое затруднение с подменой чтения/записи исходной записи на чтение/запись плавающей. Как уже говорилось, некоторые элементы управления в цикле, в котором они опрашивают поля записей (что приводит к вызову GetFieldData), изменяют единственную реализацию логического курсора в TDataSet, указатель ActiveBuffer (присваивая ему затем прежнее значение). Поэтому для того, чтобы определить, потребовали ли от TDataSet доступ именно к редактируемой записи, адрес буфера редактируемой записи надо в момент начала редактирования сохранить в какой-либо переменной, а в GetFieldData сравнивать значение ActiveBuffer с этим сохраненным значением.

Все вышесказанное естественным образом воплощается в примерно такой код:

unit DataSet3;
interface
uses DB, Classes {for TComponent};
type
  TDBCursor = integer; //Тип данных для физического курсора - номер записи
  TDefloatMode = (dmInsert, dmOverwrite);
  TRecordBuffer = packed record
    RecordIndex: TDBCursor; //Номер записи (считая от 1)
    BookmarkFlag: TBookmarkFlag;
  end;
  PRecordBuffer = ^TRecordBuffer;
  TMyDataSet = class(TDataset)
  private
    FIsOpen: boolean;
    FCursor: integer;
    FInsertingBefore: integer;
    FFloatingRecordIndex: integer;
    FEditingBuffer: pchar; //Хранит адрес буфера для редактируемой записи
    //При редактировании большую часть времени совпадает с ActiveBuffer,
    //но в процессе отрисовки связанных элементов управления последний
    //временно изменяется
  protected
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalOpen; override;
    function IsCursorOpen: Boolean; override;
    procedure InternalClose; override;
    procedure SetActive(Value: Boolean); override; //Вызывает Finalize при
    // закрытии TDataSet
    procedure Finalize; virtual; //логическое завершение текущих операций
    //(вызов Close/Post и т.п.)
    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure InternalFirst; override;
    procedure InternalLast; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function GetCanModify: Boolean; override;
    procedure InternalEdit; override;
    procedure InternalCancel; override;
    procedure DoBeforeInsert; override;
    procedure InternalInsert; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalPost; override;
    procedure InternalDelete; override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
      override;
    procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
      override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
  public
    constructor Create(AOwner: TComponent); override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean;
      override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    function BookmarkValid(Bookmark: TBookmark): Boolean; override;
  public //Конечно, это лучше реализовывать в виде свойств, но в целях
    // экономии места я сделал эти процедурные переменные полями
    FPerformOpenConnection: procedure(DS: TDataSet) of object;
    FPerformCloseConnection: procedure(DS: TDataSet) of object;
    FPerformFillFieldDefs: procedure(FieldDefsRef: TFieldDefs) of object;
    FPerformGetFieldData: procedure(Index: integer; Field: TField; out Data)
    of object;
    FPerformSetFieldData: procedure(Index: integer; Field: TField; var Data)
    of object;
    FPerformGetCanModify: function: boolean of object;
    FPerformGetRecordCount: function: integer of object;
    FPerformDeleteRecord: procedure(Index: integer) of object;
    FPerformClearFields: procedure(Index: integer) of object;
    FPerformCreateFloatingRecord: function(SourceIndex: integer): integer
    of object;
    FPerformFreeFloatingRecord: procedure(Index: integer) of object;
    FPerformDefloatRecord: procedure(FlIndex, DestIndex: integer;
      DefloatMode: TDefloatMode) of object;
    FPerformGetBookmarkSize: function: integer of object;
    FPerformGetBookmark: function(Index: integer): TBookmarkStr of object;
    FPerformSetBookmark: procedure(Index: integer; NewBookmark: TBookmarkStr)
    of object;
    FPerformFindBookmark: function(Bookmark: TBookmarkStr): integer
    of object;
  end;
implementation
uses SysUtils, forms;
procedure TMyDataSet.InternalHandleException;
begin
  Application.HandleException(Self)
end;
procedure TMyDataSet.InternalInitFieldDefs;
begin
  if Assigned(FPerformFillFieldDefs) then
    FPerformFillFieldDefs(FieldDefs)
  else
    FieldDefs.Clear;
end;
procedure TMyDataSet.InternalOpen;
begin
  InternalInitFieldDefs;
  if DefaultFields then
    CreateFields;
  BindFields(true);
  FIsOpen := true;
  FCursor := 0;
  if Assigned(FPerformGetBookmarkSize) then
    BookmarkSize := FPerformGetBookmarkSize()
  else
    BookmarkSize := 0;
  if Assigned(FPerformOpenConnection) then
    FPerformOpenConnection(self);
end;
function TMyDataSet.IsCursorOpen: Boolean;
begin
  result := FIsOpen
end;
procedure TMyDataSet.InternalClose;
begin
  if Assigned(FPerformCloseConnection) then
    FPerformCloseConnection(self);
  BindFields(False);
  if DefaultFields then
    DestroyFields;
  FIsOpen := false;
end;
procedure TMyDataSet.InternalFirst;
begin
  FCursor := 0
end;
procedure TMyDataSet.InternalLast;
begin
  FCursor := RecordCount + 1
end;
function TMyDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  result := grOK;
  case GetMode of
    gmPrior: if FCursor <= 1 then
        result := grBOF
      else
        Dec(FCursor);
    gmNext: if FCursor >= RecordCount then
        result := grEOF
      else
        Inc(FCursor);
    gmCurrent: if (FCursor < 1) or (FCursor > RecordCount) then
        Result := grError;
  end;
  if result = grOK then
    with PRecordBuffer(Buffer)^ do
    begin
      RecordIndex := FCursor;
      BookmarkFlag := bfCurrent;
    end;
  if (result = grError) and DoCheck then
    DatabaseError('Ошибка в GetRecord()');
end;
function TMyDataSet.GetRecordCount: Integer;
begin
  if Assigned(FPerformGetRecordCount) then
    Result := FPerformGetRecordCount()
  else
    raise EDatabaseError.Create('Для работы с ' + ClassName
      + ' требуется задать обработчик события OnGetRecordCount!');
end;
procedure TMyDataSet.SetRecNo(Value: Integer);
begin
  CheckBrowseMode;
  if (Value < 1) or (Value >= RecordCount + 1) then
    exit;
  FCursor := Value;
  Resync([])
end;
function TMyDataSet.GetRecNo: Integer;
begin
  Result := PRecordBuffer(ActiveBuffer)^.RecordIndex + 1
end;
procedure TMyDataSet.InternalSetToRecord(Buffer: PChar);
begin
  FCursor := PRecordBuffer(Buffer)^.RecordIndex;
end;
function TMyDataSet.AllocRecordBuffer: PChar;
begin
  GetMem(result, sizeof(TRecordBuffer))
end;
procedure TMyDataSet.FreeRecordBuffer(var Buffer: PChar);
begin
  FreeMem(Buffer)
end;
procedure TMyDataSet.InternalInitRecord(Buffer: PChar);
//Вообще-то, это просто операция очистки записи.
//Так как наш буфер не содержит указателей на динамически создаваемые
//структуры данных, то нам не нужно удалять структуры, связанные с
//предыдущим содержимым буфера. Но вот для поставщика это может быть
//необходимо, и его надо подробно уведомить о ситуации
begin
  //Если это повторный вызов (когда TDataSet уже находится в одном из режимов
  //редактирования) - такой выполняется при ClearFields - то надо просто
  //очистить запись, в противном случае TDataSet мы хотим вставить новую
  //запись, и поставщик должен сначала создать “плавающую” запись.
  if not (State in dsEditModes) then
    if Assigned(FPerformCreateFloatingRecord) then
      FFloatingRecordIndex := FPerformCreateFloatingRecord(0);
  if Assigned(FPerformClearFields) then
    FPerformClearFields(PRecordBuffer(ActiveBuffer)^.RecordIndex);
end;
function TMyDataSet.GetCanModify: Boolean;
begin
  if assigned(FPerformGetCanModify) then
    result := FPerformGetCanModify
  else
    result := false
end;
function TMyDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
var
  Index: integer;
begin
  result := assigned(FPerformGetFieldData);
  if (State in dsEditModes) and (ActiveBuffer = FEditingBuffer) then
    Index := FFloatingRecordIndex //перенаправляем к “плавающей” записи
  else
    Index := PRecordBuffer(ActiveBuffer)^.RecordIndex;
  if result then
    FPerformGetFieldData(Index, Field, Buffer^);
end;
constructor TMyDataSet.Create(AOwner: TComponent);
begin
  inherited;
  FIsOpen := false;
  if assigned(FPerformGetBookmarkSize) then
    BookmarkSize := FPerformGetBookmarkSize()
  else
    BookmarkSize := 0;
end;
function TMyDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
  result := PRecordBuffer(Buffer)^.BookmarkFlag;
end;
procedure TMyDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
begin
  PRecordBuffer(Buffer)^.BookmarkFlag := Value;
end;
procedure TMyDataSet.InternalPost;
begin
  inherited; //=CheckRequiredFields
  case State of
    dsEdit:
      if Assigned(FPerformDefloatRecord) then
        FPerformDefloatRecord(FFloatingRecordIndex, FCursor, dmOverwrite);
    dsInsert:
      begin
        if Assigned(FPerformDefloatRecord) then
          FPerformDefloatRecord(FFloatingRecordIndex, FCursor, dmInsert);
        PRecordBuffer(ActiveBuffer)^.RecordIndex := FCursor;
        PRecordBuffer(ActiveBuffer)^.BookMarkFlag := bfCurrent;
      end;
  end;
end;
procedure TMyDataSet.SetFieldData(Field: TField; Buffer: Pointer);
begin
  //Для этой операции Index всегда является индексом “плавающей” записи
  //Перенаправляем изменения в Floating record
  if Assigned(FPerformSetFieldData) then
    FPerformSetFieldData(FFloatingRecordIndex, Field, Buffer^);
  DataEvent(deFieldChange, cardinal(Field));
end;
procedure TMyDataSet.InternalDelete;
begin
  if not Assigned(FPerformGetRecordCount) then
    raise EDatabaseError.Create('Для работы с ' + ClassName
      + ' требуется задать обработчик события PerformGetRecordCount!');
  if Assigned(FPerformDeleteRecord) then
    FPerformDeleteRecord(PRecordBuffer(ActiveBuffer)^.RecordIndex);
  if FCursor = FPerformGetRecordCount() then
    Dec(FCursor);
end;
procedure TMyDataSet.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
//Согласно справке, при вызове InsertRecord активной становится вставленная
//запись. Причем можно отследить, что заботиться об этом должна
//InternalAddRecord. Поэтому в случае DoAppend просто прыгаем в конец
//(вернее, за конец)
begin
  //В момент вызова уже создана Floating-запись, и в нее скопированы значения
  if DoAppend then
    InternalLast;
  FPerformDefloatRecord(FFloatingRecordIndex, FCursor, dmInsert);
end;
procedure TMyDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
var
  res: string;
begin
  if BookmarkSize = 0 then
    exit;
  if Assigned(FPerformGetBookmark) then
    res := FPerformGetBookmark(PRecordBuffer(Buffer)^.RecordIndex)
  else
    res := '';
  strpcopy(Data, res);
end;
procedure TMyDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  if Assigned(FPerformSetBookmark) then
    FPerformSetBookmark(PRecordBuffer(Buffer)^.RecordIndex, string(pchar(Data)))
end;
procedure TMyDataSet.InternalGotoBookmark(Bookmark: Pointer);
var
  Pos: integer;
begin
  if not assigned(FPerformFindBookmark) then
    exit;
  Pos := FPerformFindBookmark(string(Bookmark));
  if Pos > -1 then
    FCursor := Pos;
end;
function TMyDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
begin
  result := assigned(FPerformFindBookmark);
  if result then
    result := (-1 <> FPerformFindBookmark(string(Bookmark)))
end;
procedure TMyDataSet.DoBeforeInsert;
begin
  inherited;
  FInsertingBefore := PRecordBuffer(ActiveBuffer)^.RecordIndex;
end;
procedure TMyDataSet.InternalInsert;
begin
  FEditingBuffer := ActiveBuffer;
  //Чтобы InternalSetToRecord переходил на правильную позицию
  with PRecordBuffer(ActiveBuffer)^ do
    if BookmarkFlag = bfInserted then
      RecordIndex := FInsertingBefore;
  //А если bfEOF или bfBOF, то InternalSetToRecord и не будет вызываться
end;
procedure TMyDataSet.InternalCancel;
begin
  if Assigned(FPerformFreeFloatingRecord) then
    FPerformFreeFloatingRecord(FFloatingRecordIndex);
end;
procedure TMyDataSet.InternalEdit;
begin
  FEditingBuffer := ActiveBuffer;
  if Assigned(FPerformCreateFloatingRecord) then
    FFloatingRecordIndex :=
      FPerformCreateFloatingRecord(PRecordBuffer(ActiveBuffer)^.RecordIndex);
end;
procedure TMyDataSet.SetActive(Value: Boolean);
begin
  if (Value <> Active) and (Value = false) then
    Finalize;
  inherited;
end;
procedure TMyDataSet.Finalize;
begin
  Cancel; //вдруг что-то редактировалось
end;
end.

А поставщик в нашем примере с адресной книгой может быть для такого упрощенного интерфейса реализован весьма несложно, например, так:

unit MyData;
interface
uses Classes, DB, DataSet3, SysUtils;
type
  TMyRecord = class
    Name: string;
    EMail: string;
    Bookmark: pointer; //В нормальном состоянии - указатель на саму запись
    constructor Create(sName, sEMail: string);
    procedure Change(sName, sEMail: string);
  end;
  TMyData = class
    List: TList;
    constructor Create; reintroduce;
    destructor Destroy; override;
    procedure FillFieldDefs(FieldDefsRef: TFieldDefs);
    procedure GetFieldData(Index: integer; Field: TField; out Data);
    procedure SetFieldData(Index: integer; Field: TField; var Data);
    function GetCanModify: boolean;
    function GetRecordCount: integer;
    procedure DeleteRecord(Index: integer);
    procedure ClearFields(Index: integer);
    function CreateFloatingRecord(SourceIndex: integer): integer;
    procedure DefloatRecord(FlIndex, DestIndex: integer;
      DefloatMode: TDefloatMode);
    function GetBookmarkSize: integer;
    function GetBookmark(Index: integer): TBookmarkStr;
    procedure SetBookmark(Index: integer; NewBookmark: TBookmarkStr);
    function FindBookmark(Bookmark: TBookmarkStr): integer;
  end;
implementation
procedure TMyRecord.Change(sName, sEMail: string);
begin
  Name := sName;
  EMail := sEMail
end;
constructor TMyRecord.Create(sName, sEMail: string);
begin
  inherited Create;
  Change(sName, sEMail);
  Bookmark := self;
end;
{ TMyData }
constructor TMyData.Create;
begin
  List := TList.Create;
  List.Add(TMyRecord.Create('Temporary', 'Temporary'));
  //Первый элемент - место под “плавающую” запись
  List.Add(TMyRecord.Create('Name1', 'email1'));
  List.Add(TMyRecord.Create('Name2', 'email2'));
  List.Add(TMyRecord.Create('Name3', 'email3'));
end;
destructor TMyData.Destroy;
var
  i: integer;
begin
  for i := 0 to List.Count - 1 do
    TMyRecord(List[i]).free;
  List.Free;
  inherited;
end;
procedure TMyData.ClearFields(Index: integer);
begin
  TMyRecord(List[0]).Name := '(name)';
  TMyRecord(List[0]).EMail := '(email)';
end;
function TMyData.CreateFloatingRecord(SourceIndex: integer): integer;
begin
  result := 0;
  if SourceIndex <> 0 then
    with TMyRecord(List[SourceIndex]) do
    begin
      TMyRecord(List[0]).Name := Name;
      TMyRecord(List[0]).EMail := EMail
    end;
end;
procedure TMyData.DefloatRecord(FlIndex, DestIndex: integer;
  DefloatMode: TDefloatMode);
begin
  if DefloatMode = dmInsert then
    List.Insert(DestIndex, TMyRecord.Create(
      TMyRecord(List[0]).Name, TMyRecord(List[0]).EMail))
      //При этом автоматически ставится новый Bookmark
  else
    with TMyRecord(List[DestIndex]) do
    begin
      Name := TMyRecord(List[0]).Name;
      Email := TMyRecord(List[0]).EMail
    end;
end;
procedure TMyData.FillFieldDefs(FieldDefsRef: TFieldDefs);
begin
  FieldDefsRef.Clear;
  with FieldDefsRef.AddFieldDef do
  begin
    DataType := ftString;
    FieldNo := 1;
    Name := 'Имя';
    Size := 40;
  end;
  with FieldDefsRef.AddFieldDef do
  begin
    DataType := ftString;
    FieldNo := 2;
    Name := 'E-Mail';
    Size := 50;
  end;
end;
procedure TMyData.DeleteRecord(Index: integer);
begin
  List.Delete(Index)
end;
function TMyData.GetCanModify: boolean;
begin
  result := true
end;
procedure TMyData.SetFieldData(Index: integer; Field: TField; var Data);
begin
  case Field.FieldNo of
    1: TMyRecord(List[Index]).Name := strpas(@Data);
    2: TMyRecord(List[Index]).Email := strpas(@Data);
  end;
end;
procedure TMyData.GetFieldData(Index: integer; Field: TField; out Data);
begin
  case Field.FieldNo of
    1: strpcopy(@Data, TMyRecord(List[Index]).Name);
    2: strpcopy(@Data, TMyRecord(List[Index]).EMail);
  end;
end;
function TMyData.GetRecordCount: integer;
begin
  result := List.Count - 1; {0-й элемент не считаем}
end;
function TMyData.GetBookmarkSize: integer;
begin
  result := 10; {'$xxxxxxxx'+NULL}
end;
procedure TMyData.SetBookmark(Index: integer; NewBookmark: TBookmarkStr);
begin
  TMyRecord(List[Index]).BookMark := pointer(strtoint(NewBookmark))
end;
function TMyData.FindBookmark(Bookmark: TBookmarkStr): integer;
var
  i: integer;
  p: pointer;
begin
  p := pointer(strtoint(pchar(Bookmark)));
  result := -1;
  for i := 1 to List.Count - 1 do
    if TMyRecord(List[i]).Bookmark = p then
    begin
      result := i;
      break
    end;
end;
function TMyData.GetBookmark(Index: integer): TBookmarkStr;
begin
  result := '$' + IntToHex(cardinal(TMyRecord(List[Index]).BookMark), 8)
end;
end.

Для проверки работы можно использовать все тот же небольшой проект, включив в Uses модуль DataSet3 вместо DataSet0, а также модуль MyData, и добавив подключение к нашему экземпляру TMyDataSet определенных в модуле MyData обработчиков событий. Для этого, конечно, потребуется создать экземпляр TMyData.

Необходимо заметить, что приведенные примеры имеют своей целью лишь показать в минимальном объеме возможную реализацию потомка TDataSet и один из способов его адаптации к простым задачам, и ни в коей мере не претендуют на качественное решение возникающих задач (например, приведенный способ поиска записи по закладке на практике при больших объемах данных может оказаться непомерно медленным). Тем не менее, примеры рабочие.

Приведенной информации, на мой взгляд, достаточно, чтобы адаптировать свои структуры данных для работы с TDataSource и DB-Aware элементами управления. Конечно, на практике могут встретиться ситуации, требующие дополнительных усилий и реализации еще каких-либо действий (например, поиска записи по значению части ее полей, фильтрации записей и т.п.); смею надеяться, однако, что выполненная мною работа поможет и в этом, несколько развеяв туман вокруг внутренних взаимосвязей методов TDataSet и восполнив катастрофических масштабов недостаток документации по этой теме.

Как создать БД в кодировке CP1251.

Вот такая конструкция проходит на DB2 2.1.2/NT и UDB5/NT...

CREATE DATABASE Efes2
USING CODESET 1251 TERRITORY RU
COLLATE USING IDENTITY;

Курсоры в ADO.

В Delphi компоненты ADOExpress довольно приятны в использовании. Однако программирование компонент ADOExpress весьма отличается от традиционного Delphi программирования в компонентах TTable и TQuery, основанных на BDE. Естевственно, что если Вы привыкли к компонентам BDE dataset, то сразу же заметите различие в количестве возможностей и свойств, а так же в стиле программирования BDE и ADO.

В основе ADO лежит объект Recordset (aka Dataset). Этот объект является результатом Query команды (например, выражение SELECT компонента TADOQuery). Когда ADO-приложение получает строки из базы данных, то объект ADO Recordset формирует необходимую информацию и операции, допустимые для получаемых данных. При этом ADO использует курсоры, чтобы хранить набор строк для обработанной записи. Так же курсор содержит в себе текущую позицию в записи (recordset). Обычно, при разработке приложения, курсоры используются при создании записей, а так же при перемещении по записям (вперёд или назад).

В ADO курсоры имеют три функции. Первая, это тип курсора, определющая допустимые перемещения в пределах курсора, а так же будут ли отражаться изменения пользователей в записи. Вторая, это местоположение курсора, определяющая место хранения записи, в то время, пока курсор остаётся открытым. Третья, это тип блокировки курсора, которая определяет как ADO datastore будет блокировать строки, если Вам потребуется внести изменения.

Каждый раз когда мы будем открывать определённую запись ADO, то мы будем открывать её с определённым типом курсора.

Класс TCustomADODataSet содержит набор свойств, событий и методов, для работы с данными, доступными через ADO datastore. Все классы-потомки от TCustomADODataSet (такие как TADODataSet, TADOTable, TADOQuery, и TADOStoredProc) совместно используют некоторые общие свойства. В каждом из этих классов присутствуют три свойства, соответствующие функциям курсоров, описанным выше: CursorType, CursorLocation, и LockType. Давайте рассмотрим эти свойства по-подробнее.

if ADOTable1.Supports(coBookmark) then ... 

Часто задаваемые вопросы по базам данных.

Оформил: DeeCo

Здесь представлены ответы на наиболее типичные вопросы, возникающие при проектировании баз данных.

A1: СУБД — Система Управления Базами Данных (DBMS — DataBase Management System). Программа, либо комплекс программ, предназначенных для полнофункциональной работы с данными. Как правило, включает в себя инструменты для создания и изменения структуры хранения наборов данных, а также средства доступа к хранимым данным, с возможностью их чтения, добавления, изменения и удаления. При этом, у большинства СУБД имеется собственный встроенный язык (возможно не один) для работы с данными. Сама база данных (БД) обычно находится просто в файлах закрытого, либо открытого формата.

A2: Под настольной (desktop) обычно подразумевается СУБД, которая всегда запускается на компьютере пользователя, хотя сама база данных может находиться в другом месте. В результате несколько копий СУБД могут обращаться к одной базе данных. Серверная (server) СУБД, как правило, запускается в на той же машине (сервере баз данных), где находятся файлы БД. Непосредственно к базе данных обращается лишь один экземпляр СУБД. Пользовательские приложения общаются только с этой СУБД через ее API, независимо от того, работают они на той же машине или на другой. Для многопользовательских баз данных более эффективным и надежным вариантом является серверная СУБД. В ней гораздо быстрее происходит доступ к данным, и значительно проще решаются конфликты между разными пользователями.

A3: Реляционная (relational) БД отличается способом представления информации, находящейся в ней. Данные в такой базе хранятся в плоских таблицах. Каждая таблица имеет собственный, заранее определенный набор именованных колонок (полей). Поля таблицы обычно соответствуют атрибутам сущностей, которые необходимо хранить в базе. Количество строк (записей) в таблице неограниченно, и каждая запись соответствует отдельной сущности. Каждая таблица должна иметь первичный ключ (ПК) — поле или набор полей, содержимое которых однозначно определяет запись в таблице и отличает ее от других. Связь между двумя таблицами обычно образуется при добавлении в первую таблицу поля, содержащего значение первичного ключа второй таблицы. Реляционные СУБД (РСУБД) предоставляют средства для всевозможных пересечений и объединений любых таблиц, отбора записей по разнообразным условиям, группировки и сортировки результатов. Реляционная база данных сочетает наглядность представления информации с простотой (относительной) реализации своей концепции и является наиболее популярной структурой для хранения данных на сегодняшний день. Достаточно подробно реляционные БД описаны в книгах [1], [2] и [3].

A4: Сервер для управления реляционными БД обычно называют SQL-сервером. SQL (Structured Query Language — язык структурированных запросов) является стандартным языком для работы с реляционными БД. Кроме стандартных реляционных операций, этот язык предоставляет возможности для изменений структуры таблиц. Различные варианты SQL используются во всех, как серверных, так и в настольных реляционных СУБД.

A5: На какой хватит денег.:) Вообще-то это может сильно зависеть от постановки задачи, количества пользователей и прихотей заказчика. Ниже приведена таблица самых распространенных SQL-серверов в порядке (примерно) убывания их возможностей:

Сервер Достоинства Недостатки IBM DB2 Universal Database Самый навороченный язык запросов, лучший оптимизатор, возможность писать функции на других языках. Высокая стоимость. Oracle Database Великое множество дополнительных возможностей. Версионный сервер. Очень высокая стоимость сервера и поддержки. Microsoft SQL Server Быстро развивающийся продукт, уже вплотную приближающийся к своим более развитым конкурентам. Средняя стоимость. Существует только для одной платформы (Win32). IBM Informix Dynamic Server Довольно развитый быстрый сервер. — Sybase Adaptive Server Enterprise Достаточно развитый сервер. Средняя стоимость. — Sybase Adaptive Server Anywhere Существует под множество платформ, включая самые экзотичные. Низкая стоимость. — Borland InterBase Приличный набор возможностей. Версионный сервер. Бесплатный. Относительно медленно работает. PostgreSQL Поддерживает историческую модель. Возможность создавать свои типы данных. Бесплатный. — MySQL Быстро работает на простых запросах. Бесплатный. Очень бедный язык запросов. Мало дополнительных возможностей.

A6: В объектно-ориентированных БД (ООБД), данные представлены в виде объектов различных классов. Как правило, имеются возможности создавать новые классы, наследовать их от уже имеющихся, задавать произвольные атрибуты и методы для классов. Для доступа к объектам, в каждой ООБД обычно предусматривается свой собственный язык, либо расширение другого языка. Пока еще ООБД недостаточно развиты и не представляют серьезной конкуренции SQL-серверам, хотя и выглядят более предпочтительными для разработчиков. Производители SQL-серверов тоже, в свою очередь, иногда делают попытки соорудить над реляционным ядром сервера объектно-ориентированную надстройку. Более подробно ООБД описаны в статье [4].

A7: Достаточно распространены следующие ООБД: Cache FastObjects GemStone/S Jasmine ObjectStore Objectivity/DB Versant

A8: Пост-реляционными, часто называют многомерные базы данных. Данные в многомерных базах, представляются в виде разреженных многомерных массивов, а не плоских таблиц, как в реляционных базах. Для определенных задач, многомерные базы могут давать значительный выигрыш в быстродействии, по сравнению с реляционными. Наиболее известные многомерные СУБД: Cache Teradata

A9: Кроме реляционных, объектно-ориентированных и многомерных СУБД, также давно известны иерархические и сетевые базы данных. Данные и связи между ними, в иерархических БД представлены в виде деревьев. Для некоторых задач, такая форма представления данных может оказаться гораздо более эффективной, чем любая другая. В сетевых базах, данные могут быть связаны произвольным образом, но эти связи должны создаваться предварительно, вместе со структурой данных. По сравнению с реляционными БД, сетевая модель может давать выигрыш в быстродействии, при некоторой потере гибкости.

A1: Под сервером БД обычно подразумевается СУБД, запущенная на той же машине, где находятся файлы БД, и монопольно распоряжающаяся этими файлами. При этом, все пользовательские приложения должны работать с базой только через эту СУБД, используя ее язык запросов.

A2: Клиентом к БД, обычно называют пользовательское приложение, которое общается с сервером БД. Модель работы, в которой клиент общается непосредственно с сервером, не используя промежуточных приложений, называется архитектурой клиент-сервер.

A3: На пользовательских машинах, обычно устанавливаются специальные программы-шлюзы, которые, через сетевой протокол, обеспечивают связь с сервером БД. Через эти шлюзы, приложения передают запросы серверу и получают результаты. Часто, дополнительно устанавливается библиотека (ODBC, OLE DB и т.п.), предоставляющая приложениям API для работы с сервером БД.

A4: Довольно распространена модель работы, когда клиент обращается не непосредственно к серверу БД, а к промежуточной программе. Эта программа обычно называется сервером приложений. Такую архитектуру называют «трехзвенной», в отличие от «двухзвенной» архитектуры клиент-сервер.

A5: Сервер приложений может использоваться для многих целей. Как правило, сервер приложений находится на отдельной машине. На него можно переложить всю функциональность программы, оставив клиенту только интерфейсную часть. Это разгрузит клиента и сервер БД от вычислений. Также, при большом количестве пользователей, можно использовать несколько серверов приложений для распределения нагрузки. А для ускорения доступа к часто используемым таблицам, их обычно кэшируют на сервере приложений.

A6: «Тонким» клиентом обычно называют пользовательское приложение, не содержащее никакой функциональности, и предназначенное только для ввода/вывода информации. Вся обработка данных производится на сервере БД, либо на сервере приложений. Зачастую, такой клиент изначально не содержит вообще никаких возможностей, а подгружает дополнительные модули с сервера, по мере необходимости. Обычно, в качестве «тонкого» клиента, выступают Web броузер + HTML/ASP/Java. «Толстый» клиент содержит всю функциональность и интерфейсную часть в себе, и при любом изменении, требует замены у всех пользователей.

A1: Данные в реляционной БД хранятся в плоских таблицах. Каждая таблица имеет собственный, заранее определенный набор именованных колонок (полей). Поля таблицы обычно соответствуют атрибутам сущностей, которые необходимо хранить в базе. Количество строк (записей) в таблице неограниченно, и каждая запись соответствует отдельной сущности. Полное описание реляционных БД можно найти в книгах [1], [2] и [3].

A2: Записи в таблице отличаются только содержимым их полей. Две записи, в которых все поля одинаковы, считаются идентичными. Каждая таблица должна иметь первичный ключ (ПК) — поле или набор полей, содержимое которых однозначно определяет запись в таблице и отличает ее от других. Отсутствие первичного ключа и наличие идентичных записей в таблице обычно возможно, но крайне нежелательно.

A3: Простейшая связь между двумя таблицами образуется при добавлении в первую таблицу поля, содержащего значение первичного ключа второй таблицы. В общем случае, реляционные БД предоставляют очень гибкий механизм для всевозможных пересечений и объединений любых таблиц, с разнообразными условиями. Для описания множеств, получающихся при пересечении и объединении таблиц, используется специальный математический аппарат — реляционная алгебра.

A4: Упорядочивание модели БД. Грубо говоря, нормализацией называют процесс выявления отдельных независимых сущностей и вынесения их в отдельные таблицы. При этом, связи с такими таблицами, обычно организуют по их первичному ключу. В результате нормализации, увеличивается гибкость работы с БД. Также, уменьшается содержание дублирующей информации в БД, а это сильно понижает вероятность возникновения ошибок.

A5: Нет. Реляционная алгебра оперирует множествами, в которых порядковый номер элемента не несет никакой смысловой нагрузки. Записи отличатся только содержимым их полей. Две записи, в которых все поля одинаковы, будут абсолютно идентичны в реляционной БД.

A1: SQL (Structured Query Language — язык структурированных запросов) является стандартным языком для работы с реляционными БД. Разделяется на две основные части: DDL (Data Definition Language — язык определения данных) и DML (Data Manipulation Language — язык обработки данных). DDL предоставляет средства для создания и изменения структуры хранения данных (БД, таблиц, процедур, типов данных и т.п.). DML предназначен для чтения и изменения данных. Основные операторы DML: select — выборка, insert — вставка, update — изменение, delete — удаление. Также, с помощью SQL, часто реализован доступ к служебным функциям SQL-сервера (заведение пользователей, создание резервных копий БД и т.д.). Подробное описание операторов и возможностей SQL имеется в книге [1].

A2: Во многих случаях, необходимо проведение группы операций по изменению данных таким образом, чтобы эта группа обладала свойством атомарности (либо вся целиком выполняется, либо вся целиком не выполняется). Такая группа операций называется транзакцией. В SQL-серверах существуют операторы, позволяющие обозначить начало транзакции (begin transaction), ее успешное завершение (commit transaction), либо откат транзакции (rollback transaction).

A3: Любые изменения данных, проведенные внутри транзакции, записываются в специальный журнал транзакций (transaction log). При откате транзакции, данные восстанавливаются в прежнем виде, а записи об изменениях удаляются из журнала транзакций.

A4: При изменении данных внутри транзакции, модифицируемые записи блокируются сервером до окончания этой транзакции. Если какая-нибудь другая транзакция пытается изменить заблокированные записи, то ее выполнение останавливается, пока не будет снята блокировка, то есть, пока не завершится первая транзакция. Некоторые сервера имеют неприятную особенность блокировать данные не отдельными записями, а целыми страницами, которые могут содержать довольно много записей.

A5: Классические «блокировочники» не дают возможности разным транзакциям одновременно изменять одни и те же записи, блокируя их на время транзакции. В результате, при попытке изменить заблокированную запись, другая транзакция будет простаивать, пока не завершиться первая. В свою очередь, «версионники» позволяют одновременно модифицировать одни и те же записи, создавая при этом разные версии одной записи.

A6: Перекрестная блокировка (deadlock) двух транзакций возникает при изменении одних и тех же записей в разном порядке. Последовательность действий, приводящая к перекрестной блокировке: 1. Транзакция A изменяет запись X. Заблокирована X. 2. Транзакция B изменяет запись Y. Заблокирована Y. 3. Транзакция A пытается изменить запись Y. Остановлена A. 4. Транзакция B пытается изменить запись X. Остановлена B. Сервер определяет перекрестную блокировку и откатывает одну из транзакций, возвращая ошибку соответствующему соединению. Аминь. Чтобы не выводить ошибку пользователю, обломанное соединение должно молча повторить транзакцию.

A7: Для ускорения операций выборки данных. При поиске полей с определенным значением, сервер вынужден перебирать все записи в таблице. В этом случае, время поиска линейно зависит от размера таблицы. Индекс по полю, обычно представляющий собой бинарное дерево, дает возможность резко сократить время поиска, превратив эту зависимость в логарифмическую. Однако, наличие индексов в таблице, замедляет операции модификации данных.

A8: Первичный ключ (ПК) — поле или набор полей, содержимое которых однозначно определяет запись в таблице и отличает ее от других. Служит для однозначной идентификации записей и в таблице может быть только один. Обычно, при определении первичного ключа, по нему автоматически создается уникальный индекс.

A9: Триггер — процедура, выполняемая сервером автоматически при модификации данных в таблице. В основном, триггеры используются для поддержания целостности дублирующей информации в денормализованной БД.

A10: Можно, практически во всех современных SQL-серверах. Различия только в синтаксисе определения и вызова функции. Кроме того, некоторые сервера позволяют использовать функции, написанные на других языках (не SQL).

A11: Обычно, в SQL-серверах можно указать одно из числовых полей как автоматически нумеруемое, причем синтаксис определения сильно зависит от разновидности сервера. При вставке новой записи, такому полю присваивается значение поля предыдущей записи + заданное приращение. Как правило, значение подобного поля нельзя явно изменять с помощью DML.

A12: Оптимизатор предназначен для определения самого быстрого способа выполнения запроса (в основном для выборки данных), при участии в нем нескольких таблиц. В простейшем случае, задача оптимизатора заключается в правильном использовании индексов при соединении таблиц и применении дополнительных условий. Иногда, можно задать в запросе дополнительную информацию (hint) для оптимизатора.

A13: Представление (view) — это запрос на выборку, хранящийся на сервере, как отдельный объект. Так как, результат этого запроса можно рассматривать в качестве таблицы, представление допускается использовать в других запросах, также как любую обычную таблицу. Материализованное представление хранится на сервере в виде таблицы, которая автоматически обновляется при изменении данных, имеющих отношение к этому представлению.

A14: Хранимые процедуры (SP — Stored Procedure) представляют собой последовательность команд на расширениях SQL, либо на других языках, поддерживаемых сервером. Могут принимать параметры и возвращать значение заданного типа. Часто используются для выполнения операций, напрямую связанных с логикой задачи, для которой проектировалась БД. Иногда, используются вместе с представлениями, для обеспечения безопасности БД (все изменения через SP, все выборки через view).

A15: Обычно, для полей в таблицах могут использоваться только самые простые типы: числа (целые и дробные), строки (сильно ограниченные по длине), дата (и время), бинарные данные большого размера (для текста, графики и т.п.). В некоторых серверах допускается использование массивов и самодельных структур.

A16: А хрен его знает. И это совсем не шутка, а его фактическое определение. Null не является пустым значением. Поэтому null + 1 = null, а не 1. Использование null означает переход от двузначной логики (true/false) к трехзначной (true/false/unknown), которая является более сложной и несколько непривычной. С другой стороны, логические операторы SQL обычно приспособлены для работы только с двузначной логикой. Поэтому использовать null для значений полей следует очень осторожно и только в тех случаях, когда без него никак нельзя обойтись. Поведение null хорошо описано в статье [5].

A17: Внешний ключ (FK — Foreign Key) используется для создания жесткой связи (многие к одному) между двумя таблицами. Внешний ключ задается только в том случае, если в первой таблице есть поле, содержащее значение первичного ключа из второй таблицы. При изменении значения первичного ключа во второй таблице, могут быть изменены все соответствующие значения связанного поля в первой таблице. При удалении записи с определенным первичным ключом из второй таблице, могут быть удалены все записи с соответствующим значением связанного поля в первой таблице. Обычно, при определении внешнего ключа, по нему автоматически создается индекс, который используется в запросах при объединении этих двух таблиц.

A18: Вообще-то он есть (ANSI SQL 92), только вот поддержка его у производителей СУБД сильно хромает. Причем дело с эти настолько плохо, что может различаться даже синтаксис основных операторов DML, не говоря уже о функциях, триггерах и прочих особенностях SQL. Поэтому о совместимости говорить сложно, хотя кое-какие сдвиги в этом направлении имеются. Наиболее близки к стандарту: Borland InterBase, Microsoft SQL Server, IBM DB2 Universal Database.

A19: Наиболее распространенным клиентским API является ODBC (Open DataBase Connectivity). ODBC-драйвера существуют на многих платформах и почти для всех SQL-серверов.

A20: Репликацией обычно называют процесс синхронизации данных между несколькими БД. Наиболее развитые SQL-сервера содержат встроенные средства репликации. Для остальных могут быть использованы продукты сторонних фирм. Одностороняя репликация подразумевает изменение данных только в одной базе, с последующей передачей изменений на остальные. Соответственно, довольно проста в реализации и надежна в работе. Двустороняя репликация предоставляет гораздо более мощный инструмент распределенной работы между SQL-серверами. Плата за это — сложность и большая вероятность конфликтов при работе.

A1: Естественным ключом (ЕК) обычно называют первичный ключ, который является смысловым атрибутом (либо набором атрибутов) сущности. Как и любой другой атрибут, ЕК подвержен изменениям, а его уникальность часто бывает притянута за уши. Суррогатным ключом (СК), как правило, называется уникальное автонумеруемое целочисленное поле в таблице, которое и является первичным ключом. СК гораздо компактнее, чем ЕК, везде занимает одно поле одинакового типа, всегда неизменен и уникален. Более обоснованное сравнение СК и ЕК производится в статье [6].

A2: Только в теории. Полностью нормализованная БД хороша для хранения данных. Но, на практике постоянно встречаются структуры, получение информации из которых, слишком сложно и медленно (а иногда и невозможно с помощью лишь оператора select). Дублирование информации в том или ином виде обычно необходимо для получения результатов выборки простыми запросами за приемлемое время.

A3: А не надо их удалять, тогда и проблемы не будет. Проще всего держать в таблице дополнительное поле Deleted (default = false), а вместо удаления записи устанавливать Deleted = true. Для выборки можно использовать представление с внутреннем условием:

Deleted = false

Возможен и более сложный вариант: два дополнительных поля DateBegin (defaul = текущая_дата) и DateEnd (defaul = максимальная_дата). Вместо удаления записи необходимо установить DateEnd = текущая_дата, а условие для выборки будет:

текущая_дата beetwen DateBegin and DateEnd

Во втором варианте есть возможность, не только иметь даты заведения/удаления записей, но и получать наборы записей на любую определенную дату с условием:

заданная_дата beetwen DateBegin and DateEnd

A4: Самый простой вариант — это создать таблицу-журнал, в которую, при изменении записи, помещать следующую информацию: дату изменения, имя (Id) пользователя, имя (Id) изменяемой таблицы, ПК записи, имя (Id) изменяемого поля и предыдущее значение поля, преобразованное в строку. Запись в журнал можно делать либо триггерами, либо из приложения. Откат изменений следует производить специальной процедурой, которая должна восстановить значения полей на заданную дату и удалить соответствующие записи из журнала. Один из вариантов журнала имеется в статье [9].

A5: Можно использовать сервер, который поддерживает историческую модель, например, PostgreSQL Server. В ином случае, можно, в дополнение к основной таблице, создать аналогичную таблицу истории, с двумя дополнительными полями: DateBegin и DateEnd. При вставке записи в основную таблицу, необходимо добавить такую же запись в таблицу истории, где DateBegin = текущая_дата, DateEnd = максимальная_дата. При модификации записи в основной таблице, нужно вставить измененную запись в таблицу истории, где DateBegin = текущая_дата, DateEnd = максимальная_дата. При этом у предыдущей соответствующей записи в таблице истории необходимо установить DateEnd = текущая_дата. При удалении записи в основной таблице, у последней соответствующей записи в таблице истории надо установить DateEnd = текущая_дата. Выборка из основной таблицы производится обычным образом, а из таблицы истории с условием:

заданная_дата beetwen DateBegin and DateEnd

Сходные варианты представления истории рассматриваются в статье [10].

A6: В таблицу, которую надо сделать иерархической, надо добавить поле Parent, содержащее значение ПК родительской записи. Далее, все зависит от задачи и возможностей сервера. Если нет необходимости углубляться в иерархию более чем на один уровень, либо сервер поддерживает рекурсивные запросы, то этого вполне хватит. Иначе, придется использовать дополнительные поля, либо вспомогательную таблицу. Подробно способы представления деревьев в реляционных БД описаны в статьях [7] и [8].

A7: Вообще-то, в большинстве SQL-серверов есть системный каталог — набор стандартных таблиц, содержащих информацию обо всех объектах сервера и БД. Правда, таблицы эти предназначены не для разработчика, а для внутреннего использования самим сервером, поэтому найти там что-либо весьма проблематично. При этом, структура их может меняться даже в разных версиях одного сервера. Поэтому, желательно создать в БД собственный системный каталог, полностью описывающий структуру базы и взаимосвязи ее объектов. Такой каталог можно переносить на другой сервер вместе с БД, не заботясь о совместимости, а информацию из него можно легко использовать в приложении для каких-либо действий (вплоть до автоматической генерации самого приложения). Пример системного каталога приведен в статье [9].

A8: Проще всего файлы держать отдельно в выделенной директории на сервере, а в базе хранить только их имена. Единственной проблемой в таком случае будет раздача прав на эту директорию. Кроме того, в SQL-серверах есть возможность определять бинарные поля большого размера, которые можно использовать для хранения разных видов файлов. Чтобы не замедлять работу с обычными данными, рекомендуется создавать отдельно таблицу, содержащую такие поля. Также, при использовании больших полей, можно обнаружить разнообразные ограничения на сервере и клиенте.

A9: Такие действия проще всего выполнять на клиенте. Если надо на сервере, то лучше использовать предназначенные для этого возможности оператора выборки:

1. select top n * from t order by a
2. select * from t order by a limit n,m

Когда ничего такого сервер не поддерживает, можно использовать в условии выборки подзапрос, возвращающий номер текущей строки результата (если поле сортировки не уникально, то в подзапрос нужно добавить еще какое-нибудь условие для обеспечения уникальности значений, возвращаемых подзапросом):

select * from t as t_outer where 
( select count( * ) from t as t_inner where t_inner.a <= t_outer.a ) between n and m
order by a

В крайнем случае, можно выбирать данные во временную таблицу с дополнительным автонумеруемым полем RowNumber, а из нее затем делать выборку:

select ... where RowNumber >= n and RowNumber <= m

A10: Самый правильный способ — это использовать вложенный запрос, в котором ищется максимальное значение поля. Затем найденное значение используется в условии основного запроса.

select *
from t
where a = ( select max( a ) from t )

Если максимальное значение необходимо искать не во всей таблице, а по определенному полю, то запрос будет следующего вида:

select *
from t as t_outer
where a = ( select max( t_inner.a ) from t as t_inner where t_inner.b = t_outer.b )

Чтобы избежать появления в результате запроса нескольких одинаковых записей, соответствующих одному максимальному значению, можно использовать ключевое слово distinct.

A11: Подобные запросы обычно умеют делать разнообразные генераторы отчетов. SQL же не предусматривает такой возможности. Хотя, при желании, можно сделать процедуру, использующую динамический SQL. В ней придется составлять запрос на основе данных из таблицы, а затем выполнять его.

A12: Нумерация записей очень легко делается на любом клиенте. Чтобы в запросе получить поле, соответствующее номеру записи, можно использовать подзапрос, возвращающий количество записей, меньших либо равных (сравнение — по полю сортировки) текущей записи:

select *,
( select count( * ) from t as t_inner where t_inner.a <= t_outer.a ) as RowNumber
from t as t_outer
order by a

Если поле сортировки не уникально, то в подзапрос необходимо добавить дополнительное условие сравнения (например, по первичному ключу) для обеспечения уникальности значений, возвращаемых подзапросом.

A13: Можно вообще хранить все дополнительные объекты в одной таблице, содержащей идентификатор объекта, идентификатор атрибута и само значение атрибута, преобразованное в строку. Чтобы не было мучительно больно при получении результатов запросов, лучше все-таки использовать несколько таблиц — отдельно для каждого типа данных. Более серьезный вариант универсального хранилища объектов рассмотрен в статье [11]. PS: А чем была плоха идея насчет создания/изменения таблиц?

API — Application Program Interface DB — DataBase DBMS — DataBase Management System DDL — Data Definition Language DML — Data Manipulation Language FK — Foreign Key ODBC — Open DataBase Connectivity PK — Primary Key RDBMS — Relational DataBase Management System SP — Stored Procedure SQL — Structured Query Language.

БД — База Данных ЕК — Естественный Ключ ООБД — Объектно-Ориентированная База Данных ООСУБД — Объектно-Ориентированная Система Управления Базами Данных ПК — Первичный Ключ РСУБД — Реляционная Система Управления Базами Данных СУБД — Система Управления Базами Данных СК — Суррогатный Ключ.

Запуск файлов хрянящихся в БД.

Автор: Дмитрий WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запуск файлов хрянящихся в БД
Данный код реализует чтение из Бд строки где спрятан путь к файлу,
далее для удачного запуска "курсор" переместим в папку, от куда надо
запустить разбиваем строку на файл(для запуска) и на директорию
(для перемещения "курсора").
Переброска "курсора" необходима для правильного запуска приложения.
Приложение может быть как под Windows, так и под Dos.
Зависимости: Windows, SysUtils
Автор:       Дмитрий, ahmaev@mail.ru, ICQ:100716670, Пенза
Copyright:   Дмитрий
Дата:        9 июля 2002 г.
***************************************************** }
procedure TForm1.dxfColorButton1Click(Sender: TObject);
var
  s, files1, files: string;
  dir, dir1: string;
  apchar: array[0..500] of char;
  i_s1: integer;
begin
  {Находим нужную строку в Бд}
  table1.locate('kod_s', treeview1.selected.parent.index + 1,
    [loCaseInsensitive]);
  table2.locate('game', treeview1.selected.Text, [loCaseInsensitive]);
  {Перепишем из БД строки содержащие ссылки в переменные}
  s := table2.fields[4].asstring;
  k_s := length(table2.fields[4].asstring) + 1;
  files := '';
  dir := '';
  repeat
    i_s := i_s + 1;
    k_s := k_s - 1;
    {Поставим семафор, чтоб разделить путь и имя файла}
    if s[k_s] = '\' then
      en := 1;
    if s[k_s] <> '\' then
      if en = 0 then
        files := files + s[k_s];
    if en = 1 then
      dir := dir + s[k_s];
  until i_s = length(table2.fields[4].asstring);
  {Переворачиваем считанное "путь до файла" и "имя файла"}
  for i_s1 := length(files) downto 1 do
    files1 := files1 + files[i_s1];
  for i_s1 := length(dir) downto 1 do
    dir1 := dir1 + dir[i_s1];
  {Переводим курсор в папку откуда должна запустится программа}
  chdir(dir1);
  strpcopy(apchar, files1);
  {Запускаем программу}
  shellexecute(handle, 'open', apchar, 0, 0, SW_maximize);
end;

Отобразить определенного формата файлы базы данных.

unit DdhDynDb;
interface
uses
  Controls, Db, Forms, Classes, DbTables;
function ConvertClass(FieldClass: TFieldClass): TControlClass;
procedure NormalizeString(var S: string);
procedure ConnectDataFields(DbComp: TControl;
  DataSource: TDataSource; FieldName: string);
function GenerateForm(StrList: TStringList;
  SourceTable: TTable): TForm;
function GenerateSource(AForm: TForm;
  FormName, UnitName: string): string;
implementation
uses
  TypInfo, DbCtrls, SysUtils, StdCtrls, ExtCtrls, Windows;
const
  FieldTypeCount = 15;
type
  CVTable = array[1..FieldTypeCount, 1..2] of TClass;
  // TBytesField and TVarBytesField are missing
const
  ConvertTable: CVTable = (
    (TAutoIncField, TDBEdit),
    (TStringField, TDBEdit),
    (TIntegerField, TDBEdit),
    (TSmallintField, TDBEdit),
    (TWordField, TDBEdit),
    (TFloatField, TDBEdit),
    (TCurrencyField, TDBEdit),
    (TBCDField, TDBEdit),
    (TBooleanField, TDBCheckBox),
    (TDateTimeField, TDBEdit),
    (TDateField, TDBEdit),
    (TTimeField, TDBEdit),
    (TMemoField, TDBMemo),
    (TBlobField, TDBImage), {just a guess}
    (TGraphicField, TDBImage));
function ConvertClass(FieldClass: TFieldClass):
  TControlClass;
var
  I: Integer;
begin
  Result := nil;
  for I := 1 to FieldTypeCount do
    if ConvertTable[I, 1] = FieldClass then
    begin
      Result := TControlClass(
        ConvertTable[I, 2]);
      break; // jump out of for loop
    end;
  if Result = nil then
    raise Exception.Create('ConvertClass failed');
end;
procedure NormalizeString(var S: string);
var
  N: Integer;
begin
  // remove the T
  Delete(S, 1, 1);
  {chek if the string is a valid Pascal identifier:
  if not, replace spaces and other characters with underscores}
  if not IsValidIdent(S) then
    for N := 1 to Length(S) do
      if not ((S[N] in ['A'..'Z']) or (S[N] in ['a'..'z'])
        or ((S[N] in ['0'..'9']) and (N <> 1))) then
        S[N] := '_';
end;
procedure ConnectDataFields(DbComp: TControl;
  DataSource: TDataSource; FieldName: string);
var
  PropInfo: PPropInfo;
begin
  if not Assigned(DbComp) then
    raise Exception.Create(
      'ConnectDataFields failed: Invalid control');
  // set the DataSource property
  PropInfo := GetPropInfo(
    DbComp.ClassInfo, 'DataSource');
  if PropInfo = nil then
    raise Exception.Create(
      'ConnectDataFields failed: Missing DataSource property');
  SetOrdProp(DbComp, PropInfo,
    Integer(Pointer(DataSource)));
  // set the DataField property
  PropInfo := GetPropInfo(
    DbComp.ClassInfo, 'DataField');
  if PropInfo = nil then
    raise Exception.Create(
      'ConnectDataFields failed: Missing DataField property');
  SetStrProp(DbComp, PropInfo, FieldName);
end;
function GenerateForm(StrList: TStringList;
  SourceTable: TTable): TForm;
var
  I, NumField, YComp, HForm, Hmax: Integer;
  NewName: string;
  NewLabel: TLabel;
  NewDBComp: TControl;
  CtrlClass: TControlClass;
  ATable: TTable;
  ADataSource: TDataSource;
  APanel: TPanel;
  ANavigator: TDBNavigator;
  AScrollbox: TScrollBox;
begin
  // generate the form and connect the table
  Result := TForm.Create(Application);
  Result.Position := poScreenCenter;
  Result.Width := Screen.Width div 2;
  Result.Caption := 'Table Form';
  // create a Table component in the result form
  ATable := TTable.Create(Result);
  ATable.DatabaseName := SourceTable.DatabaseName;
  ATable.TableName := SourceTable.TableName;
  ATable.Active := True;
  ATable.Name := 'Table1';
  // component position (at design time)
  ATable.DesignInfo := MakeLong(20, 20);
  // create a DataSource
  ADataSource := TDataSource.Create(Result);
  ADataSource.DataSet := ATable;
  ADataSource.Name := 'DataSource1';
  // component position (at design time)
  ADataSource.DesignInfo := MakeLong(60, 20);
  // create a toolbar panel
  APanel := TPanel.Create(Result);
  APanel.Parent := Result;
  APanel.Align := alTop;
  APanel.Name := 'Panel1';
  APanel.Caption := '';
  // place a DBNavigator inside it
  ANavigator := TDBNavigator.Create(Result);
  ANavigator.Parent := APanel;
  ANavigator.Left := 8;
  ANavigator.Top := 8;
  ANAvigator.Height := APanel.Height - 16;
  ANavigator.DataSource := ADataSource;
  ANavigator.Name := 'DbNavigator1';
  // create a scroll box
  AScrollbox := TScrollBox.Create(Result);
  AScrollbox.Parent := Result;
  AScrollbox.Width := Result.ClientWidth;
  AScrollbox.Align := alClient;
  AScrollbox.BorderStyle := bsNone;
  AScrollbox.Name := 'ScrollBox1';
  // generates field editors
  YComp := 10;
  for I := 0 to StrList.Count - 1 do
  begin
    NumField := Integer(StrList.Objects[I]);
    // create a label with the field name
    NewLabel := TLabel.Create(Result);
    NewLabel.Parent := AScrollBox;
    NewLabel.Name := 'Label' + IntToStr(I);
    NewLabel.Caption := StrList[I];
    NewLabel.Top := YComp;
    NewLabel.Left := 10;
    NewLabel.Width := 120;
    // create the data aware control
    CtrlClass := ConvertClass(
      ATable.FieldDefs[NumField].FieldClass);
    NewDBComp := CtrlClass.Create(Result);
    NewDBComp.Parent := AScrollBox;
    NewName := CtrlClass.ClassName +
      ATable.FieldDefs[NumField].Name;
    NormalizeString(NewName);
    NewDBComp.Name := NewName;
    NewDBComp.Top := YComp;
    NewDBComp.Left := 140;
    NewDbComp.Width :=
      AScrollBox.Width - 150; // width of label plus border
    // connect the control with the data source
    // and field using RTTI support
    ConnectDataFields(NewDbComp,
      ADataSource,
      ATable.FieldDefs[NumField].Name);
    // compute the position of the next component
    Inc(YComp, NewDBComp.Height + 10);
  end; // for each field
  // computed requested height for client area
  HForm := YComp + APanel.Height;
  // max client area hight = screen height - 40 - form border
  HMax := (Screen.Height - 40 -
    (Result.Height - Result.ClientHeight));
  // limit form height to HMax and reserve space for scrollbar
  if HForm > HMax then
  begin
    HForm := HMax;
    Result.Width := Result.Width +
      GetSystemMetrics(SM_CXVSCROLL);
  end;
  Result.ClientHeight := HForm;
end;
function GenerateSource(AForm: TForm;
  FormName, UnitName: string): string;
var
  I: Integer;
begin
  SetLength(Result, 20000);
  // generate the first part of the unit source
  Result :=
    'unit ' + UnitName + ';'#13#13 +
    'interface'#13#13 +
    'uses'#13 +
    '  SysUtils, WinTypes, WinProcs, Messages, Classes,'#13 +
    '  Forms, Graphics, Controls, Dialogs, DB, DBCtrls,'#13 +
    '  DBTables, ExtCtrls;'#13#13 +
    'type'#13 +
    '  T' + FormName + ' = class(TForm)'#13;
  // add each component of the form
  for I := 0 to AForm.ComponentCount - 1 do
    Result := Result +
      '    ' + AForm.Components[I].Name +
      ': ' + AForm.Components[I].ClassName + ';'#13;
  // generate the final part of the source code
  Result := Result +
    '  private'#13 +
    '    { Private declarations }'#13 +
    '  public'#13 +
    '    { Public declarations }'#13 +
    '  end;'#13#13 +
    'var'#13 +
    '  ' + FormName + ': T' + FormName + ';'#13#13 +
    'implementation'#13#13 +
    '{$R *.DFM}'#13#13 +
    'end.'#13;
end;
end.

unit DdhDbwF;
interface
uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, Grids, DB, DBTables,
  Buttons, Mask, DBCtrls;
type
  TFormDbWiz = class(TForm)
    Notebook1: TNotebook;
    Label1: TLabel;
    ListDatabases: TListBox;
    BitBtnNext1: TBitBtn;
    BitBtnNext2: TBitBtn;
    Label2: TLabel;
    ListTables: TListBox;
    BitBtnBack2: TBitBtn;
    ListFields: TListBox;
    Label3: TLabel;
    BitBtnNext3: TBitBtn;
    BitBtnBack3: TBitBtn;
    Label4: TLabel;
    BitBtnNext4: TBitBtn;
    BitBtnBack4: TBitBtn;
    GroupFilter: TRadioGroup;
    BitBtnAll: TBitBtn;
    BitBtnNone: TBitBtn;
    StringGrid1: TStringGrid;
    Table1: TTable;
    procedure Notebook1PageChanged(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListDatabasesClick(Sender: TObject);
    procedure BitBtnNext1Click(Sender: TObject);
    procedure ListTablesClick(Sender: TObject);
    procedure BitBtnBack2Click(Sender: TObject);
    procedure BitBtnNext2Click(Sender: TObject);
    procedure BitBtnBack3Click(Sender: TObject);
    procedure BitBtnAllClick(Sender: TObject);
    procedure BitBtnNoneClick(Sender: TObject);
    procedure BitBtnNext3Click(Sender: TObject);
    procedure BitBtnBack4Click(Sender: TObject);
    procedure ListFieldsClick(Sender: TObject);
    procedure BitBtnNext4Click(Sender: TObject);
  private
    { Private declarations }
  public
    SourceCode, FormName, UnitName: string;
    ResultForm: TForm;
    procedure GeneratedFormClose(
      Sender: TObject; var Action: TCloseAction);
  end;
var
  FormDbWiz: TFormDbWiz;
implementation
{$R *.DFM}
uses
  DdhDynDb, ExptIntf;
////// form code //////
procedure TFormDbWiz.Notebook1PageChanged(Sender: TObject);
begin
  // copy the name of the page into the caption
  Caption := Format(
    'Ddh DB Form Wizard - Page %d/%d: ',
    [NoteBook1.PageIndex + 1,
    NoteBook1.Pages.Count,
      NoteBook1.ActivePage]);
end;
procedure TFormDbWiz.FormCreate(Sender: TObject);
begin
  // fill the first listbox with database names
  Session.GetDatabaseNames(
    ListDatabases.Items);
  // start in the first page
  Notebook1.PageIndex := 0;
  // default values (modified by the wizard)
  FormName := 'TResultForm';
  UnitName := 'ResultUnit';
end;
procedure TFormDbWiz.ListDatabasesClick(Sender: TObject);
begin
  // database selected: enable the Next button
  BitBtnNext1.Enabled := True;
end;
procedure TFormDbWiz.BitBtnNext1Click(Sender: TObject);
var
  CurrentDB, CurrentFilter: string;
begin
  // get the database and filters
  CurrentDB := ListDatabases.Items[
    ListDatabases.ItemIndex];
  CurrentFilter := GroupFilter.Items[
    GroupFilter.ItemIndex];
  // retrieve the tables
  Session.GetTableNames(CurrentDB,
    CurrentFilter, True, False, ListTables.Items);
  // move to the next page
  NoteBook1.PageIndex := 1;
  BitBtnNext2.Enabled := False;
end;
procedure TFormDbWiz.ListTablesClick(Sender: TObject);
begin
  // table selected: enable next button
  BitBtnNext2.Enabled := True;
end;
procedure TFormDbWiz.BitBtnBack2Click(Sender: TObject);
begin
  // go back to first page
  NoteBook1.PageIndex := 0;
end;
procedure TFormDbWiz.BitBtnNext2Click(Sender: TObject);
var
  I: Integer;
begin
  // set the properties of the selected table
  with Table1 do
  begin
    DatabaseName := ListDatabases.Items[
      ListDatabases.ItemIndex];
    TableName := ListTables.Items[
      ListTables.ItemIndex];
    // load the field definitions
    FieldDefs.Update;
  end;
  // clear the list box, then fill it
  ListFields.Clear;
  for I := 0 to Table1.FieldDefs.Count - 1 do
    // add number, name, and class name of each field
    ListFields.Items.Add(Format(
      '%d) %s [%s]',
      [Table1.FieldDefs[I].FieldNo,
      Table1.FieldDefs[I].Name,
        Table1.FieldDefs[I].FieldClass.ClassName]));
  // move to the next page
  NoteBook1.PageIndex := 2;
  BitBtnNext3.Enabled := False;
end;
procedure TFormDbWiz.BitBtnBack3Click(Sender: TObject);
begin
  // back to the second page
  NoteBook1.PageIndex := 1;
end;
procedure TFormDbWiz.BitBtnAllClick(Sender: TObject);
var
  I: Integer;
begin
  // select every available field
  for I := 0 to ListFields.Items.Count - 1 do
    ListFields.Selected[I] := True;
  // enable Next button
  BitBtnNext3.Enabled := True;
end;
procedure TFormDbWiz.BitBtnNoneClick(Sender: TObject);
var
  I: Integer;
begin
  // deselect all the fields
  for I := 0 to ListFields.Items.Count - 1 do
    ListFields.Selected[I] := False;
  // disable next button (no fields are selected)
  BitBtnNext3.Enabled := False;
end;
procedure TFormDbWiz.ListFieldsClick(Sender: TObject);
begin
  // enable button if there at least one field selected
  BitBtnNext3.Enabled := ListFields.SelCount > 0;
end;
procedure TFormDbWiz.BitBtnNext3Click(Sender: TObject);
var
  I, RowNum: Integer;
begin
  // reserve enough rows in the string grid
  StringGrid1.RowCount := ListFields.Items.Count;
  // empty the string grid
  for I := 0 to StringGrid1.RowCount - 1 do
  begin
    StringGrid1.Cells[0, I] := '';
    StringGrid1.Cells[1, I] := '';
  end;
  // for each field, if selected list it with the
  // corresponding data aware component
  RowNum := 0;
  for I := 0 to ListFields.Items.Count - 1 do
    if ListFields.Selected[I] then
    begin
      StringGrid1.Cells[0, RowNum] := Format('%d) %s [%s]',
        // field number, name, classname of data aware control
        [Table1.FieldDefs[I].FieldNo,
        Table1.FieldDefs[I].Name,
          ConvertClass(Table1.FieldDefs[I].FieldClass).ClassName]);
      StringGrid1.Cells[1, RowNum] := Table1.FieldDefs[I].Name;
      Inc(RowNum);
    end;
  // set the real number of rows
  StringGrid1.RowCount := RowNum;
  NoteBook1.PageIndex := 3;
end;
procedure TFormDbWiz.BitBtnBack4Click(Sender: TObject);
begin
  NoteBook1.PageIndex := 2;
end;
// generate button
procedure TFormDbWiz.BitBtnNext4Click(Sender: TObject);
var
  StrList: TStringList;
  I, RowNum: Integer;
begin
  StrList := TStringList.Create;
  Screen.Cursor := crHourGlass;
  try
    RowNum := 0;
    for I := 0 to ListFields.Items.Count - 1 do
      if ListFields.Selected[I] then
      begin
        StrList.AddObject(
          StringGrid1.Cells[1, RowNum], TObject(I));
        // move to next row in string grid
        Inc(RowNum);
      end;
    ResultForm := GenerateForm(StrList, Table1);
    if not Assigned(ToolServices) then
    begin
      // stand alone form
      ResultForm.OnClose := GeneratedFormClose;
      ResultForm.Show;
    end
    else
    begin
      // wizard
      SourceCode := GenerateSource(ResultForm,
        FormName, UnitName);
      ModalResult := mrOK;
    end;
  finally
    Screen.Cursor := crDefault;
    StrList.Free;
  end;
end;
procedure TFormDbWiz.GeneratedFormClose(
  Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;
end.

Как узнать содержание активной записи в БД.

Следующая функция возвращает в виде указателя на строку содержание активной записи в БД.

function TBDEDirect.GetCurRecord(Lock: DBILockType): PChar;
var
  Res: DBIResult;
  RecSize: Word;
  RecBuf: PChar;
  Bookmark: TBookmark;
begin
  Result := StrNew('');
  if CheckDatabase then
  begin
    RecSize := GetPhysicalRecSize;
    RecBuf := StrAlloc(RecSize+1);
    FillChar(RecBuf^, RecSize+1, #0);
    Bookmark := FDataLink.DataSource.DataSet.GetBookmark;
    DbiSetToBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark);
    FDataLink.DataSource.DataSet.FreeBookmark(Bookmark);
    Res := DbiGetRecord(FDataLink.DataSource.DataSet.Handle, Lock, RecBuf, nil);
    if Res = 0 then
      Result := RecBuf
    else
      Check(Res);
  end;
end;

Как активизировать компоненты доступа к данным связанные с определенным TDatabase.

for i:=0 to pred(DB1.DataSetCount) do
  {if DataSets.Tag = 1 then}
  DataSets[i].Open;

Быстрый доступ к нужной записи в таблице Paradox.

var
  NeedNumber: Integer;
...
NeedNumber := Table.RecNo;
{сохранение номера нужной записи}
...
{код меняющий номе записи}
...
Table.RecNo := NeedNumber;
{востановление номера нужной записи}

Контекстное меню на основе базы данных.

var
  m: TMenuItem;
  navidummy: TComponent;
  ..........................................................
  procedure TMyForm.CreatePopUpMM(Sender: TObject);
begin
  Navidummy.free;
  Navidummy := TComponent.create(self);
  while not NaviT.EOF do
  begin
    m := TMenuItem.create(navidummy);
    II := II + 1;
    with m do
    begin
      name := 'MM' + IntToStr(II);
      caption := NaviT.Fieldbyname('MyWHAT').AsString;
      tag := NaviT.Fieldbyname('MyTAG').AsInteger;
      visible := True;
      OnClick := NaviExec;
    end;
    MyMenuItem.add(m);
    NaviT.Next;
  end;
  NaviT.Close;
end;
procedure TMyForm.NaviExec(Sender: TObject);
begin
  { Здесь я получаю то, что хочу ! }
  What.text := (Sender as TMenuItem).Caption;
  Key := (Sender as TMenuItem).Tag;
end;

БД-дерево взаимоотношений.

Master    Slave  ------- имена полей
Peter     Jane
Peter     Simon

Master    Slave  ------- имена полей
Peter     Jane
Peter     Simon
Jane      George
Jane      Elisa

Пример:

AddFather('Peter')
AddChild('Peter', 1)
procedure AddFather(Name: string)
begin
  Tree.Add(Name);
end;
procedure AddChildr(Name: string, Index: Integer)
begin
  Relation.FindKey([Name])
  while RelationMaster.AsString = Name do
  begin
    Tree.AddChild(Index, RelationSlave.AsString);
    AddChild(RelationSlave.AsString, Tree.ItemsCount);
    Relation.Next;
  end;
end;

По-моему, ошибок нет.

Сортировка связанного списка.

Автор: Peter Below

program noname;
type
  PData = ^TData;
  TData = record
    next: PData;
    Name: string[40];
    { ...другие поля данных }
  end;
var
  root: PData; { это указатель на первую запись в связанном списке }
procedure InsertRecord(var root: PData; pItem: PData);
(* вставляем запись, на которую указывает pItem в список начиная
с root и с требуемым порядком сортировки *)
var
  pWalk, pLast: PData;
begin
  if root = nil then
  begin
    (* новый список все еще пуст, просто делаем запись,
    чтобы добавить root к новому списку *)
    root := pItem;
    root^.next := nil
  end { If }
  else
  begin
    (* проходимся по списку и сравниваем каждую запись с одной
    включаемой. Нам необходимо помнить последнюю запись,
    которую мы проверили, причина этого станет ясна немного позже. *)
    pWalk := root;
    pLast := nil;
    (* условие в следующем цикле While определяет порядок сортировки!
    Это идеальное место для передачи вызова функции сравнения,
    которой вы передаете дополнительный параметр InsertRecord для
    осуществления общей сортировки, например:
    While CompareItems( pWalk, pItem ) < 0 Do Begin
    where
    Procedure InsertRecord( Var list: PData; CompareItems: TCompareItems );
    and
    Type TCompareItems = Function( p1,p2:PData ): Integer;
    and a sample compare function:
    Function CompareName( p1,p2:PData ): Integer;
    Begin
    If p1^.Name < p2^.Name Then
    CompareName := -1
    Else
    If p1^.Name > p2^.Name Then
    CompareName := 1
    Else
    CompareName := 0;
    End;
    *)
    while pWalk^.Name < pItem^.Name do
      if pWalk^.next = nil then
      begin
        (* мы обнаружили конец списка, поэтому добавляем
        новую запись и выходим из процедуры *)
        pWalk^.next := pItem;
        pItem^.next := nil;
        Exit;
      end { If }
      else
      begin
        (* следующая запись, пожалуйста, но помните,
        что одну мы только что проверили! *)
        pLast := pWalk;
        (* если мы заканчиваем в этом месте, то значит мы нашли
        в списке запись, которая >= одной включенной. Поэтому
        вставьте ее перед записью, на которую в настоящий момент
        указывает pWalk, которая расположена после pLast. *)
        if pLast = nil then
        begin
          (* Упс, мы вывалились из цикла While на самой первой итерации!
          Новая запись должна располагаться в верхней части списка,
          поэтому она становится новым корнем (root)! *)
          pItem^.next := root;
          root := pItem;
        end { If }
        else
        begin
          (* вставляем pItem между pLast и pWalk *)
          pItem^.next := pWalk;
          pLast^.next := pItem;
        end; { Else }
        (* мы сделали это! *)
      end; { Else }
  end; { InsertRecord }
procedure SortbyName(var list: PData);
var
  newtree, temp, stump: PData;
begin { SortByName }
  (* немедленно выходим, если сортировать нечего *)
  if list = nil then
    Exit;
  (* в
  newtree := Nil;
  (********
  Сортируем, просто беря записи из оригинального списка и вставляя их
  в новый, по пути "перехватывая" для определения правильной позиции в
  новом дереве. Stump используется для компенсации различий списков.
  temp используется для указания на запись, перемещаемую из одного
  списка в другой.
  ********)
  stump := list;
  while stump <> nil do
  begin
    (* временная ссылка на перемещаемую запись *)
    temp := stump;
    (* "отключаем" ее от списка *)
    stump := stump^.next;
    (* вставляем ее в новый список *)
    InsertRecord(newtree, temp);
  end; { While }
  (* теперь помещаем начало нового, сортированного
  дерева в начало старого списка *)
  list := newtree;
end; { SortByName }
begin
  New(root);
  root^.Name := 'BETA';
  New(root^.next);
  root^.next^.Name := 'ALPHA';
  New(root^.next^.next);
  root^.next^.next^.Name := 'Torture';
  WriteLn(root^.name);
  WriteLn(root^.next^.name);
  WriteLn(root^.next^.next^.name);
end.

Структура DCB.

Описание в эквиваленте C.

typedef struct _DCB { // dcb  
    DWORD DCBlength;           // Размер DCB
    DWORD BaudRate;            // Скорость пересылки данных в бодах; 
                               // текущая скорость в бодах 
    DWORD fBinary: 1;          // binary mode, no EOF check 
                               // двоичный режим , не проверять конец 
                               // данных (по умолчанию значение = 1)
    DWORD fParity: 1;          // Включить проверку четность (по умолчанию
                               // значение = 1)
    DWORD fOutxCtsFlow:1;      // CTS управление потоком выхода 
    DWORD fOutxDsrFlow:1;      // DSR управление потоком выхода 
    DWORD fDtrControl:2;       // DTR Тип управления потоком скорости 
                               // передачи данных
    DWORD fDsrSensitivity:1;   // DSR sensitivity (чувствительность)
    DWORD fTXContinueOnXoff:1; // XOFF continues Tx (стоп-сигнал 
                               // продалжает выполнение)
    DWORD fOutX: 1;            // XON/XOFF out flow control (СТАРТ-  
                               // СИГНАЛ / СТОП-СИГНАЛ для управления 
                               // выходящим потоком (по умолчанию
                               // значение = 1)
    DWORD fInX: 1;             // XON/XOFF in flow control (СТАРТ-
                               // СИГНАЛ / СТОП-СИГНАЛ для управления 
                               // входящим потоком (по умолчанию
                               // значение = 1)
    DWORD fErrorChar: 1;       // enable error replacement (включить 
                               // проверку погрешностей по умолчанию=1)
    DWORD fNull: 1;            // enable null stripping (отвергать
                               // пустой поток данных (по умолчанию=1))
    DWORD fRtsControl:2;       // RTS управление потоком данных
    DWORD fAbortOnError:1;     // abort reads/writes on error  
                               // (проверять операции чтения/записи 
                               // по умолчанию=1)
    DWORD fDummy2:17;          // reserved ЗАРЕЗЕРВИРОВАНО 
    WORD wReserved;            // not currently used НЕ ДЛЯ 
                               // ИСПОЛЬЗОВАНИЯ 
    WORD XonLim;               // transmit XON threshold (порог 
                               // чувствительности старт-сигнала)
    WORD XoffLim;              // transmit XOFF threshold (порог
                               // чувствительности стоп-сигнала)
    BYTE ByteSize;             // Бит в байте  (обычно 8)
    BYTE Parity;               // 0-4=no,odd,even,mark,space 
                               // (четность байта)
    BYTE StopBits;             // 0,1,2 = 1, 1.5, 2 (стоповые биты)
    char XonChar;              // Tx and Rx XON character (вид
                               // старт сигнал в потоке)
    char XoffChar;             // Tx and Rx XOFF character (вид
                               // стоп сигнал в потоке)
    char ErrorChar;            // error replacement character (какой     
                               // сигнал погрешности,его вид)
    char EofChar;              // end of input character (сигнал 
                               // окончания потока)
    char EvtChar;              // received event character  РЕЗЕРВ
    WORD wReserved1;           // reserved; do not use НЕ ДЛЯ 
                               // ИСПОЛЬЗОВАНИЯ
} DCB; 

Пример :

with Mode do
begin
  BaudRate := 9600;
  ByteSize := 8;
  Parity := NOPARITY;
  StopBits := ONESTOPBIT; // одиночный стоп-бит
  Flags := EV_RXCHAR + EV_EVENT2;
end;

BaudRate Определяет скорость в бодах, в которых порт оперирует. Этот параметр может принимать фактическое значение скорости в бодах, или один из следующих стандартных индексов скорости в бодах:

CBR_110 	CBR_19200
CBR_300 	CBR_38400
CBR_600 	CBR_56000
CBR_1200	CBR_57600
CBR_2400	CBR_115200
CBR_4800	CBR_128000
CBR_9600	CBR_256000
CBR_14400	

Использование 5 информационных разрядов с 2 стоповыми битами - недопустимая комбинация, как - 6, 7, или 8 информационных разрядов с 1.5 стоповыми битами.

Использование компилятора Delphi (dcc32.exe) в прикладных программах.

Оформил: DeeCo

Автор: Сергей Гурин.

Хотя в названии статьи тема выглядит довольно узко, я хотел бы рассказать не только об использовании dcc32, но и о технологии, которой я дал условное название "многозвенное программирование", хотя вынести это название в заголовок статьи мне показалось неправильным. Какой смысл я вкладываю в термин "многозвенное программирование"? Начну издалека. Работу над более или менее большими программами можно разделить на два крупных этапа. Первый этап - это собственно разработка, которая включает формулировку технического задания, увязку требований заказчика, проектную фазу, итеративное уточнение структуры проекта, программирование, отладку и тестирование. Первый этап заканчивается выпуском первой версии и началом эксплуатации программы у заказчика (или у массы пользователей, если программа была разработана по собственной инициативе для распространения или продажи). Затем наступает этап сопровождения, который включает устранение обнаруживаемых ошибок, адаптацию к постоянно изменяющимся требованиям заказчика, ввод дополнительных возможностей, которые не были оговорены в исходном задании. Часто бывает так - за время сопровождения программа претерпевает настолько существенные изменения, что сопровождение ее становится делом гораздо более трудоемким и хлопотным, чем разработка.

Если первый этап достаточно хорошо поддерживается разнообразным программистским инструментарием, то второй этап в этом смысле поддержан значительно хуже. Главной целью "многозвенного программирования" как раз и является поддержка этапа сопровождения. В чем основная идея этого подхода? Рассмотрим простую схему:

В этой схеме заказчик использует только те функциональные возможности программы, которые предоставлены разработчиком. Для изменения этих возможностей заказчик выставляет требования разработчику, разработчик изменяет программу и возвращает заказчику. Таким образом, при интенсивном изменении требований к программе, у разработчика всегда большая загрузка, а у заказчика постоянно тормозится работа. Рассмотрим другую схему:

В этой схеме заказчик образно разделяется на две составляющие - технолог и пользователь. Под технологом здесь понимается человек (или группа), который является посредником между разработчиком и пользователем. Технолог профессионально владеет той предметной областью, для которой разработана программа, но не является программистом - это может быть энергетик, астроном, режиссер. Причем, такое разделение заказчика может быть чисто условным - один и тот же человек может выполнять функции, как технолога, так и конечного пользователя. Технолог - это ключевое звено в цепочке. Технолог знает предметную область значительно лучше разработчика и, весьма часто, хотел бы изменить функционирование программы так, как не было предусмотрено программистом. Частые обращения к разработчику могут быть весьма затруднительными - как во времени, так и в пространстве.

Для улучшения этой ситуации можно сделать следующее - передать часть работы программиста технологу. Поскольку технолог по определению не является программистом, нужна дополнительная связующая часть. Такой связующей частью может быть проблемно-ориентированный язык, который разработчик включает в свой проект и которым технолог может воспользоваться для изменения функциональности программы (в разумных пределах). Естественно, что этот язык должен оперировать терминами той предметной области, в которой работает технолог. То есть, между формулировкой задачи и языком ее решения нужен минимальный семантический разрыв. Универсальные языки программирования на эту роль явно не подойдут. Внешней синтаксической формой проблемно-ориентированного языка может быть текст, граф, схема, короче то, на чем технолог наиболее адекватно формулирует свои конкретные задачи. Таким образом, интенсивность взаимодействия между разработчиком и технологом может быть уменьшена, так как значительную часть изменений технолог может делать самостоятельно.

Эта идея используется многими разработчиками, но в литературе я не встречал ее обсуждения как инструмента для сопровождения. В этом смысле вместо термина "многозвенное программирование" обычно используется термин "проблемно-ориентированный язык".

В многозвенной структуре, которую я нарисовал выше, содержится только 2 программирующих звена, но в реальности этих звеньев может быть больше. Если предметная область достаточно разнородна, то "технолог" может быть целой цепочкой технологов - конкретный пример я приведу в самом конце статьи.

Конечно, здесь есть и другая сторона медали - маркетинговые соображения. Если заказчик получит развиваемый инструмент, то разработчик может остаться в проигрыше. И чем лучше инструмент, тем менее вероятно, что заказчик будет оплачивать сопровождение программы. Здесь уже решать разработчику - или заниматься только сопровождением старых программ или высвобождать время для новых разработок.

Вот собственно то, что я хотел сказать о технологии "многозвенного программирования". Теперь практическая часть. Как можно реализовать такую технологию? Один из наиболее используемых вариантов - это встраивание в программу интерпретатора проблемно-ориентированного языка. Встраивание компилятора я встречал значительно реже. В своей программистской практике я использовал оба варианта. Достоинства интерпретатора очевидны, но также очевидны и недостатки. Общий принцип состоит в том, что интерпретатор либо каждый раз интерпретирует исходное представление программы на проблемно-ориентированном языке, либо порождает промежуточный код, исполняемый некоторой виртуальной машиной. Примеры - пакет Microsoft Office с языком VB for Applications, реализация языка Java. Сюда же относятся все скриптовые языки. Если требуется межплатформенная совместимость, то интерпретаторы, вероятно, будут лучшим вариантом. Если же более важны соображения эффективности, то компиляция оказывается более предпочтительным выбором. Общий принцип - берем описание задачи на проблемно-ориентированном языке, генерируем соответствующий код на некотором универсальном языке, компилируем его и выполняем.

В этом разделе статьи я расскажу о втором варианте - использование компилятора, а конкретно, dcc32.exe из поставки Delphi (хотя можно использовать любой другой быстрый и качественный компилятор для любого другого подходящего языка).

Далее я рассмотрю этапы, которые нужно сделать, чтобы воплотить замыслы технолога. Конкретности реализации демонстрируется на примере небольшой библиотеки, которую прилагаю к статье (называется она DccUsing) и крошечного проекта под незатейливым именем DccExamples.

На основе исходного представления, которое формулирует технолог, нужно сгенерировать код для компиляции. Исходное представление может быть любым, в простейшем случае - это обычный текст. В процессе генерации кода наибольшее внимание нужно уделить диагностике ошибок. То есть, ошибки желательно выявить во время генерации кода и генерировать уже синтаксически правильный код. Для этого можно использовать любые доступные методы, вплоть до синтаксических анализаторов с рекурсивным спуском - такие анализаторы достаточно просты и описаны во многих книгах, например у Бьерна Страуструпа в "Язык программирования C++" (Третье издание). Если есть возможность, то желательно контролировать также семантическую правильность. Далее я буду рассматривать только те моменты, которые являются общими для всех задач без учета их специфики.

public
  procedure IncLevel;
  procedure DecLevel;
  procedure AddSpace;
  procedure AddLine(const aLine: String);
  procedure AddLines(const aLines: array of String);
  procedure AddFile(const aFileName: String);
  procedure AddLineTemplate(const aLine: String;
                            const aArgs: array of String);
  procedure AddLinesTemplate(const aLines, aArgs: array of String);
  procedure AddFileTemplate(const aFileName: String;
                            const aArgs: array of String);
  procedure AddPoint(aPoint: Integer);
  function  FindPoint(aLine: Integer): Integer;
  property  Level: Integer read FLevel;
  property  LinesCount: Integer read FLinesCount;

Первые три метода позволяют управлять форматированием кода. Хотя форматирование совсем не обязательно (код никто не читает), но дает удобства при отладке, а, кроме того, мне нравится, когда программа выглядит эстетично. IncLevel увеличивает отступ текста, DecLevel уменьшает, а AddSpace добавляет в поток пустую строку. Два следующих метода добавляют в поток соответственно строку и массив строк, а метод AddFile - весь указанный файл. Свойства позволяют узнать текущий уровень отступа и текущее число строк в потоке. Назначение методов AddPoint и FindPoint будет объяснено в разделе диагностики ошибок.

const
  tFunc: array[0..5] of string = (
    'function {{1}}.SortProc{{2}}(const a1, a2: {{2}}): Integer;',
    'begin',
    '  if      a2 > a1 then result := 1',
    '  else if a2 = a1 then result := 0',
    '  else                 result := -1;',
    'end;'
    );
  //то при использовании
  c.AddLinesTemplate(tFunc, ['TTestClass1', 'Integer']);
  //мы получим такой результат:
function TTestClass1.SortProcInteger(const a1, a2: Integer): Integer;
begin
  if a2 > a1 then
    result := 1
  else if a2 = a1 then
    result := 0
  else
    result := -1;
end;
//а при использовании
c.AddLinesTemplate(tFunc, ['TTestClass2', 'String']);
//такой:
function TTestClass2.SortProcString(const a1, a2: string): Integer;
begin
  if a2 > a1 then
    result := 1
  else if a2 = a1 then
    result := 0
  else
    result := -1;
end;

public
  constructor Create(const aFileName: String);
  destructor  Destroy; override;
  property    FileName: String read FFileName;
{Конструктор принимает имя файла и открывает файл на чтение, а деструктор
закрывает файл. 
Класс TStringCompileOut хранит генерируемый текст в памяти:}
public
  procedure Clear;
  procedure SaveToFile(const aFileName: String);
  procedure SaveToOut(aOut: TCompileOut);
  property  Capacity: Integer ...
  property  Items[aIndex: Integer]: String ... default;

Методы класса позволяют очистить поток, сохранить поток в файле и добавить его к другому потоку. Свойства позволяют изменить резервируемый объем памяти для списка строк и получить доступ на запись и чтение строк по индексу. Общее число строк определяет наследуемое свойство LinesCount. Примеры использования этих классов смотрите в DccExamples.pas.

Отметим, что часть неизменяемого или шаблонного кода может быть заготовлена заранее, располагаться в файлах и объединяться в нужных местах результирующего кода с помощью AddFile и AddFileTemplate. По ходу генерации кода может быть создано несколько потоков - для деклараций переменных и констант, деклараций и реализаций классов и так далее. После просмотра всей задачи, сформулированной технологом, эти потоки сшиваются в один результирующий поток. Для частных потоков можно использовать строковую реализацию, а для результирующего потока - файловую.

После того, как исходный код создан, требуется его откомпилировать. Компилятор dcc32 замечательно подходит для этой роли - он очень быстрый, качественный и объединяет в себе все, что необходимо для построения exe-файлов, dll-библиотек и пакетов. Размер файла dcc32.exe (версия 12.0, из Delphi 5) всего 545 Кб, ранние версии имеют еще меньший размер. К нему нужно добавить только три файла - rlink32.dll, sysinit.dcu и system.dcu (это минимум). Компилятор и указанные файлы можно разместить в подкаталоге прикладной программы, например, bin. Генерировать текст целесообразно в подкаталоге компилятора, например, bin\pas, чтобы использовать короткие пути файлов и не засорять каталог компилятора.

Для вызова dcc32.exe в библиотеке DccUsing определена функция ExecDcc32. Она устанавливает текущий каталог, создает файл для перехвата ошибок компиляции, вызывает компилятор, дожидается завершения компиляции и определяет наличие ошибок.

function ExecDcc32(const aDccDir, aOptions,
  aProjectPath, aErrorPath: string;
  aCheckPaths: Boolean = False): Boolean;

// сохранение текущего каталога и установка нового
CurDir := GetCurrentDir;
if not SetCurrentDir(DccDir) then
  raise Exception.Create(SCantChangeDir + DccDir);
try
  hStdOut := INVALID_HANDLE_VALUE;
  try
    // установки атрибутов безопасности
    with SecurAtt do
    begin
      nLength := SizeOf(SecurAtt);
      lpSecurityDescriptor := nil;
      // разрешить наследование дочернему процессу
      bInheritHandle := BOOL(True);
    end;
    // создание файла, в который будут направляться ошибки
    hStdOut := CreateFile(PChar(aErrorPath), GENERIC_WRITE, 0,
      @SecurAtt, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
    if hStdOut = INVALID_HANDLE_VALUE then
      raise Exception.Create(SCantCreateFile + aErrorPath);
    // заполнение структуры, специфицирующей создание процесса
    ZeroMemory(@StartupInfo, SizeOf(StartupInfo));
    with StartupInfo do
    begin
      cb := SizeOf(StartupInfo);
      // скрывать окно компилятора и наследовать потоки ввода-вывода
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdOutput := hStdOut;
    end;
    // создать и стартовать процесс компилятора
    s := 'dcc32.exe ' + aOptions + ' ' + aProjectPath;
    if not CreateProcess('dcc32.exe', PChar(s), @SecurAtt, @SecurAtt,
      BOOL(True), 0, nil, PChar(DccDir), StartupInfo, ProcessInfo) then
      raise Exception.Create(SCantCreateProcess + 'dcc32.exe');
    // ждать завершение компиляции неопределенное время
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    // получить результат компиляции
    ResultCode := 0;
    GetExitCodeProcess(ProcessInfo.hProcess, ResultCode);
    result := ResultCode = 0;
  finally
    // закрыть файл ошибок
    if hStdOut <> INVALID_HANDLE_VALUE then
      CloseHandle(hStdOut);
  end;
finally
  // восстановить прежний каталог по умолчанию
  SetCurrentDir(CurDir);
end;

Установка каталога компилятора, как текущего, позволяет не заботиться о мелочах, связанных с назначением путей. Компилятор направляет сообщения об ошибках в стандартный файл вывода. Для его перехвата создаем свой файл, дескриптор которого передаем компилятору. Для того, чтобы процесс компилятора мог наследовать дескриптор открытого файла, устанавливаем его атрибут наследования. При заполнении структуры StartupInfo указываем, что окно компилятора должно быть скрытым и порождаемый процесс должен наследовать стандартные потоки ввода-вывода. Атрибуты безопасности, передаваемые функции создания процесса, нужны для правильной работы в NT, в Windows 95-98 их можно было бы опустить. Функция CreateProcess сохраняет параметры процесса в структуре ProcessInfo - мы используем дескриптор процесса, чтобы передать его функции ожидания системного события - в данном случае, завершения процесса. С помощью GetExitCodeProcess получаем значение, которое возвращает компилятор. Если компиляция была успешной, то возвращается 0, иначе - ненулевое значение. Операции закрытия файла ошибок и восстановления предыдущего каталога произойдут независимо от возможных исключительных ситуаций по ходу функции ExecDcc32.

Компилятору, вместе с исходным файлом (файлами), нужно также передать файл проекта (dpr) и уточнить в опциях, что же будет результатом компиляции. Возможных вариантов много - GUI или консольное приложение, dll, пакет, ActiveX (наверное, есть еще варианты). Выбор вида компиляции связан со спецификой задачи, требованиями пользователя и вкусами разработчика. К этому вопросу я еще раз вернусь в разделе Исполнение кода.

TCompileMessageStatus = (cmsNone, cmsHint, cmsWarning,
                         cmsError, cmsFatal);
public
  procedure ParseFile(const aFileName: String);
  function  MessagesCount: Integer;
  function  StatusCount(aStatus: TCompileMessageStatus): Integer;
  function  MessageText(aIndex: Integer): String;
  function  MessageStatus(aIndex: Integer): TCompileMessageStatus;
  function  MessageFile(aIndex: Integer): String;
  function  MessageLine(aIndex: Integer): Integer;

TCompileMessageStatus перечисляет все возможные статусы ошибок. Процедура ParseFile выполняет разбор файла ошибок и сохраняет результат в своем приватном списке. Функция MessagesCount возвращает общее количество сообщений, а StatusCount - количество сообщений с заданным статусом. Оставшиеся 4 функции разбирают строку сообщения компилятора на составляющие - текст сообщения, статус, имя файла, в котором обнаружена ошибка и номер строки.

Вот теперь можно вернуться к необъясненным методам TCompileOut. Метод AddPoint добавляет в поток контрольную точку. Контрольная точка - это просто целое число, которое помечает уникальным номером начало некоторой части генерируемого кода и жестко связывается с номером строки. Контрольная точка может служить, например, индексом в таблице ошибок. Расставив при генерации кода такие точки-метки, мы можем локализовать место ошибки. Для поиска ошибки нужно повторить генерацию кода без вызова компилятора (чтобы опять сформировать выходной поток), а затем, для результирующего выходного потока, вызвать функцию FindPoint, передав ей номер ошибочной строки. Эта функция определит ближайшую точку ошибки. Если генерируется несколько файлов исходных кодов, то выбор ошибочного файла сделать с помощью функции, возвращающей имя файла - MessageFile.

Как я уже говорил, возможны различные варианты того, в какой вид будет скомпилирована задача, сформулированная технологом. Если технолог передает результаты своей работы конечному пользователю, то удобный вариант - exe-файл. Если технолог решает некоторую задачу и сразу же пользуется результатами решения, то сам факт компиляции должен быть для него полностью прозрачен (или максимально незаметен). Технолог работает в программе, которая сделана разработчиком и, по большому счету, ему совершенно безразлично, каким конкретно способом разработчик предоставляет возможность изменять функциональность программы. Существует несколько технологий построения гибко подгружаемых модулей, и они описаны в литературе. Я остановлюсь только на одной технологии - динамическая загрузка и выгрузка DLL. Если результирующий проект, который нужен технологу, содержит визуальные формы (а их можно генерировать как dfm-файлы), то вероятно, более предпочтительными будут пакеты.

Возможен также вариант, когда исполняемый код делится на две составляющие - исполняемое ядро (exe-файл) и подгружаемый модуль. Ядро создается разработчиком и динамически подключает модули, создаваемые технологом. Достоинство такого подхода в том, что работу с визуальными компонентами можно сосредоточить в ядре, а в DLL формировать только алгоритмическую часть задачи. Другое достоинство такого подхода - технолог может работать в мощной интегрированной среде, а конечному пользователю он передает только ядро и нужный модуль, скрывая от пользователя все технологические детали.

public
  constructor Create(const aDllPath: String);
  destructor  Destroy; override;
  function    Execute(const aFunctionName: String;
               const aInterface: Pointer): Pointer;

Конструктор Create просто сохраняет путь к файлу DLL и больше ничего не делает, деструктор Destroy выгружает DLL из памяти, если она была загружена. Основную работу делает метод Execute - он вызывает экспортируемую функцию DLL по имени и передает ей указатель на интерфейс вызывающей части. Экспортируемая функция возвращает интерфейс вызываемой части. Более подробно о взаимодействии вызывающей и вызываемой частей поговорим в следующем разделе, а пока рассмотрим реализацию метода Execute.

function TDllWrap.Execute(const aFunctionName: string;
  const aInterface: Pointer): Pointer;
var
  f: TDllFunction;
begin
  if FDllInst = 0 then
  begin
    if not FileExists(FDllPath) then
      raise Exception.Create(SFileNotFound + FDllPath);
    FDllInst := LoadLibrary(PChar(FDllPath));
    if FDllInst = 0 then
      raise Exception.Create(SCantLoadDll +
        SysErrorMessage(GetLastError));
  end;
  f := TDllFunction(GetProcAddress(FDllInst,
    PChar(aFunctionName)));
  if not Assigned(f) then
    raise Exception.Create(SCantFindFunction + aFunctionName);
  result := f(aInterface);
end;

Вначале метод Execute контролирует - загружена ли DLL? и, если DLL еще не загружена, то она загружается. Если загрузка была успешной, то с помощью функции GetProcAddress получаем адрес экспортируемой функции по ее символическому имени (можно также использовать индекс). Если адрес функции успешно получен, то вызываем ее и передаем ей аргумент - указатель на вызывающий интерфейс. Функция возвращает указатель на вызываемый интерфейс. Из этой реализации видно, что вызывающая часть может обратиться с помощью метода Execute к нескольким различным функциям DLL или многократно к одной и той же функции - DLL будет загружена только один раз.

TDllFunction = function(aInterface: Pointer): Pointer; StdCall;

IMaster = class
public
  procedure Method1; virtual; abstract;
  .............
end;

uses
  UnitIMaster, UnitISlave;
type
  TSlaveObject = class(ISlave)
  private
    FMain: IMain;
  public
    constructor Create(aMain: IMain);
    destructor Destroy; override;
    procedure Method1; override;
    ............
  end;
function CreateSlave(aInterface: Pointer): Pointer; stdcall;
  function DestroySlave(aInterface: Pointer): Pointer; stdcall;
  implementation
var
    SlaveObject: TSlaveObject;
    // Реализация TSlaveObject
    ............
  function CreateSlave(aInterface: Pointer): Pointer;
begin
  SlaveObject := TSlaveObject.Create(IMaster(aInterface));
  result := SlaveObject;
end;
function DestroySlave(aInterface: Pointer): Pointer;
begin
  SlaveObject.Free;
  SlaveObject := nil;
  result := nil;
end;
initialization
  SlaveObject := nil;
finalization
  SlaveObject.Free;
end.

Эффект использования описанной технологии повышается при увеличении сложности программы, для простых программ она вряд ли целесообразна. В качестве примера я расскажу об одной из своих разработок: Visual2k - Интегрированная среда для программирования микроконтроллерных кукол-роботов. Подробнее о ней и о других программах, использующих "многозвенное программирование" можно узнать на моем web-сайте.

Программа Visual2k разработана для томского театра кукол "2+Ку" и проекта "Оживление пространства". Суть проекта состоит в создании кукол-роботов, используемых в рекламных целях, в витринах магазинов и кафе, в качестве гидов на выставках. Куклы могут быть одиночными или работать совместно в автоматическом спектакле. Разработка каждого нового проекта включает в себя такие фазы - художник и сценарист по заказу придумывают сценарий спектакля, затем, вместе с конструкторами обсуждают детали реализации. Когда детали проекта уточнились, инженер-электронщик изготавливает микроконтроллерную аппаратуру, инженер-механик конструирует механику кукол и приводы двигателей, а режиссер - создает с готовыми куклами спектакль. То есть, здесь мы имеем целую цепочку технологов, каждый из которых работает со своей предметной областью.

Visual2k содержит подсистемы, которые позволяют всем технологам работать над проектом в одной и той же интегрированной среде. Задача первого технолога (электронщика) - не только сконструировать аппаратуру, но и начать создание базы проекта. Вот так выглядит подсистема, в которой он работает:

Электронщик вносит в базу проекта имена и типы микроконтроллеров, а также назначает привязку приводов к конкретным выводам микроконтроллеров. Этой информации достаточно, чтобы автоматически сгенерировать программу для микроконтроллеров. Исходный код программы для микроконтроллеров генерируется на языке Си с использованием заранее заготовленной библиотеки драйверов и компилируется Си-компилятором. В зависимости от типа микроконтроллера, генерируется тот или иной Си код.

После этого, файл проекта поступает ко второму технологу (механику). Он работает в этой же подсистеме и создает актеров или их части, назначает действия, которые должны делать куклы-актеры и учитывает специфику приводов, например, создает таблицу скоростей двигателей.

Полученный файл проекта вместе с готовой механикой и электроникой поступает к третьему технологу - режиссеру. Он работает уже с другой предметной областью - сценарием. Поскольку сценарии бывают очень сложными, то режиссер программирует движения кукол на простом алгоритмическом языке, который включает в себя понятия параллельных и последовательных веточек, циклов, условий и команд управления куклами. Вот как выглядит подсистема, в которой работает режиссер:

Здесь стоит отметить, что Visual2k немного напоминает Delphi, с той разницей, что здесь все представлено визуальными компонентами, даже переменные и операторы. Режиссер выстраивает сценарий, выкладывая на рабочую область компоненты-операторы, и назначает их свойства с помощью инспектора объектов. Программа сценария, полученная таким образом, может выполняться либо на персональном компьютере (для сложных говорящих кукол или спектаклей), либо на одном микроконтроллере или сети микроконтроллеров. Исходный вид сценария один и тот же, но генерируется либо текст на языке Object Pascal, который компилируется dcc32, либо текст на языке Си, объединяемый с частью, заданной электронщиком и компилируемый Си-компилятором. Поскольку в операторах присваивания и в условиях могут быть выражения, Visual2k включает в себя синтаксический анализатор выражений, обнаруживающий все синтаксические ошибки и заменяющий русские имена переменных и функций на имена, допустимые для языка Pascal. Если кукольный проект будет выполняться под управлением персонального компьютера, то сценарий компилируется в DLL, которая вызывается исполняющим ядром. Такая структура позволяет передавать заказчику только исполняющее ядро и DLL, не раскрывая фирменных секретов спектакля. Параллельные процессы, необходимые для адекватного описания сценария реализуются на базе библиотеки параллельного программирования Gala. Если же сценарий выполняется в микроконтроллере, то используется специально разработанная многозадачная среда с кооперативной мультизадачностью и сценарий зашивается прямо в ПЗУ.

Когда мы получили первый заказ на кукольный спектакль, программы Visual2k еще не было, и я писал сценарий самостоятельно (на Delphi) - режиссер сидел рядом ничего не понимая в том, что я делаю, и только давал советы. Я плохо понимал, чего хочет режиссер, а режиссер вообще не понимал, что я делаю. После создания Visual2k, я занимался только развитием интегрированной среды, добавлял поддержку новых типов микроконтроллеров и новых типов приводов, совершенно не вникая в то, какие делались спектакли. Режиссер очень быстро освоил простой язык описания сценариев и получил полную свободу в реализации своих режиссерских замыслов. Так мне удалось расправиться с целым стадом зайцев - существенно облегчить себе задачу сопровождения программы, освободиться от написания конкретных сценариев, освободить электронщика от написания программ для микроконтроллера и высвободить себе время для других разработок.

Скачать файлы проекта DccUsing.Zip (80K).

В чем разница между сокетами, DCOM и OLE Enterprise при использовании их в качестве транспорта.

DCOM permissions.

Автор: Абдулин Марат WEB-сайт: ООО "АТОЛ технологии"

Как пользоваться DCOM.

Настройка DCOM при помощи DCOMCNFG.EXE

Закладка Applications Позиционироваться на сервер.exe. Кнопка "Properties...".

Программная настройка DCOM

DefaultProperties.

DefaultSecurity.

Application Security.

Закладка Identity.

Все остальные процедуры и функции модуля BDcomPrm носят служебный характер.

Как можно работать с DDE под Delphi, используя вызовы API.

Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру: { *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** }, поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi.

{ *** НАЧАЛО КОДА DDEMLCLI.DPR *** }
program Ddemlcli;
uses
  Forms,
  Ddemlclu in 'DDEMLCLU.PAS' {Form1};
{$R *.RES}
begin
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLCLI.DPR *** }
{ *** НАЧАЛО КОДА DDEMLCLU.DFM *** }
object Form1: TForm1
  Left = 197
    Top = 95
    Width = 413
    Height = 287
    HorzScrollBar.Visible = False
    VertScrollBar.Visible = False
    Caption = 'Демонстрация DDEML, Клиентское приложение'
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    Menu = MainMenu1
    PixelsPerInch = 96
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    OnShow = FormShow
    TextHeight = 16
    object PaintBox1: TPaintBox
    Left = 0
      Top = 0
      Width = 405
      Height = 241
      Align = alClient
      Color = clWhite
      ParentColor = False
      OnPaint = PaintBox1Paint
  end
  object MainMenu1: TMainMenu
    Top = 208
      object File1: TMenuItem
      Caption = '&Файл'
        object exit1: TMenuItem
        Caption = 'В&ыход'
          OnClick = exit1Click
      end
    end
    object DDE1: TMenuItem
      Caption = '&DDE'
        object RequestUpdate1: TMenuItem
        Caption = '&Запрос на обновление'
          OnClick = RequestUpdate1Click
      end
      object AdviseofChanges1: TMenuItem
        Caption = '&Сообщение об изменениях'
          OnClick = AdviseofChanges1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object PokeSomeData: TMenuItem
        Caption = '&Пропихивание данных'
          OnClick = PokeSomeDataClick
      end
    end
  end
end
{ ***  КОНЕЦ КОДА DDEMLCLU.DFM *** }
{ *** НАЧАЛО КОДА DDEMLCLU.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}
{ Это демонстрационное приложение, демонстрирующее использование
DDEML API в клиентском приложении. Оно использует серверное
приложение DataEntry, которое является частью данной демонстрации,
и служит для ввода данных и отображения их на графической панели.
Сначала вы должны запустить приложение-сервер (в DDEMLSRV.PAS),
а затем стартовать клиента. Если сервер не запущен, клиент при
попытке соединения потерпит неудачу.
Интерфейс сервера определен списком имен (Service, Topic и Items)
в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер
делает Items доступными в формате cf_Text; они преобразовываются
и хранятся локально как целые. }
unit Ddemlclu;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;
const
  NumValues = 3;
type
  { Структура данных, представленная в примере }
  TDataSample = array[1..NumValues] of Integer;
  TDataString = array[0..20] of Char; { Размер элемента как текста }
  { Главная форма }
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    exit1: TMenuItem;
    DDE1: TMenuItem;
    RequestUpdate1: TMenuItem;
    AdviseofChanges1: TMenuItem;
    PokeSomeData: TMenuItem;
    N1: TMenuItem;
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure RequestUpdate1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure AdviseofChanges1Click(Sender: TObject);
    procedure PokeSomeDataClick(Sender: TObject);
    procedure Request(HConversation: HConv);
    procedure exit1Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    { Private declarations }
  public
    Inst: Longint;
    CallBackPtr: ^TCallback;
    ServiceHSz: HSz;
    TopicHSz: HSz;
    ItemHSz: array[1..NumValues] of HSz;
    ConvHdl: HConv;
    DataSample: TDataSample;
  end;
var
  Form1: TForm1;
implementation
const
  DataEntryName: PChar = 'DataEntry';
  DataTopicName: PChar = 'SampledData';
  DataItemNames: array[1..NumValues] of pChar = ('DataItem1',
    'DataItem2',
    'DataItem3');
{$R *.DFM}
  { Локальная функция: Процедура обратного вызова для DDEML }
function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ;
  Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
begin
  CallbackProc := 0; { В противном случае смотрите доказательство }
  case CallType of
    xtyp_Register:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_Unregister:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_xAct_Complete:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_Request, Xtyp_AdvData:
      begin
        Form1.Request(Conv);
        CallbackProc := dde_FAck;
      end;
    xtyp_Disconnect:
      begin
        ShowMessage('Соединение разорвано!');
        Form1.Close;
      end;
  end;
end;
{ Посылка DDE запроса для получения cf_Text данных с сервера.
Запрашиваем данные для всех полей DataSample, и обновляем
окно для их отображения. Данные с сервера получаем синхронно,
используя DdeClientTransaction.}
procedure TForm1.Request(HConversation: HConv);
var
  hDdeTemp: HDDEData;
  DataStr: TDataString;
  Err, I: Integer;
begin
  if HConversation <> 0 then
  begin
    for I := Low(ItemHSz) to High(ItemHSz) do
    begin
      hDdeTemp := DdeClientTransaction(nil, 0, HConversation, ItemHSz[I],
        cf_Text, xtyp_Request, 0, nil);
      if hDdeTemp <> 0 then
      begin
        DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
        Val(DataStr, DataSample[I], Err);
      end; { if }
    end; { for }
    Paintbox1.Refresh; { Обновляем экран }
  end; { if }
end;
procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
  { Создаем экземпляр окна DDE-клиента. Создаем окно, используя
  унаследованный конструктор, инициализируем экземпляр данных.}
begin
  Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
  CallBackPtr := nil; { MakeProcInstance вызывается из SetupWindow    }
  ConvHdl := 0;
  ServiceHSz := 0;
  TopicHSz := 0;
  for I := Low(DataSample) to High(DataSample) do
  begin
    ItemHSz[I] := 0;
    DataSample[I] := 0;
  end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы
DDE строк, и освобождаем экземпляр функции обратного вызова,
если она существует. Также, для завершения диалога, вызовите
DdeUninitialize. Затем, для завершения работы, вызовите
разрушителя предка. }
var
  I: Integer;
begin
  if ServiceHSz <> 0 then
    DdeFreeStringHandle(Inst, ServiceHSz);
  if TopicHSz <> 0 then
    DdeFreeStringHandle(Inst, TopicHSz);
  for I := Low(ItemHSz) to High(ItemHSz) do
    if ItemHSz[I] <> 0 then
      DdeFreeStringHandle(Inst, ItemHSz[I]);
  if Inst <> 0 then
    DdeUninitialize(Inst); { Игнорируем возвращаемое значение }
  if CallBackPtr <> nil then
    FreeProcInstance(CallBackPtr);
end;
procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
  { Генерируем запрос DDE в ответ на выбор пункта меню DDE | Request.}
  Request(ConvHdl);
end;
procedure TForm1.FormShow(Sender: TObject);
{ Завершаем инициализацию окна сервера DDE. Выполняем те действия,
которые требует правильное окно. Инициализируем использование DDEML. }
var
  I: Integer;
  InitOK: Boolean;
begin
  CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);
  { Инициализируем DDE и устанавливаем функцию обратного вызова.
  Если сервер отсутствует, вызов терпит неудачу. }
  if CallBackPtr <> nil then
  begin
    if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly,
      0) = dmlErr_No_Error then
    begin
      ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
      TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
      InitOK := True;
      {     for I := Low(DataItemNames) to High(DataItemNames) do begin }
      for I := 1 to NumValues do
      begin
        ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
          cp_WinAnsi);
        InitOK := InitOK and (ItemHSz[I] <> 0);
      end;
      if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then
      begin
        ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
        if ConvHdl = 0 then
        begin
          ShowMessage('Не могу инициализировать диалог!');
          Close;
        end
      end
      else
      begin
        ShowMessage('Не могу создать строки!');
        Close;
      end
    end
    else
    begin
      ShowMessage('Не могу осуществить инициализацию!');
      Close;
    end;
  end;
end;
procedure TForm1.AdviseofChanges1Click(Sender: TObject);
{ Переключаемся на режим DDE Advise с помощью пункта меню DDE |
Advise (уведомление). При выборе этого пункта меню все три
элемента переключаются на уведомление. }
var
  I: Integer;
  TransType: Word;
  TempResult: Longint;
begin
  with TMenuITem(Sender) do
  begin
    Checked := not Checked;
    if Checked then
      TransType := (xtyp_AdvStart or xtypf_AckReq)
    else
      TransType := xtyp_AdvStop;
  end; { with }
  for I := Low(ItemHSz) to High(ItemHSz) do
    if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,
      TransType, 1000, @TempResult) = 0 then
      ShowMessage('Не могу выполнить транзакцию-уведомление');
  if TransType and xtyp_AdvStart <> 0 then
    Request(ConvHdl);
end;
procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта
меню DDE | Poke. Запрашиваем значение у пользователя,
которое будем "проталкивать" в DataItem1 в качестве
иллюстрации Poke-функции.}
var
  DataStr: pChar;
  S: string;
begin
  S := '0';
  if InputQuery('PokeData', 'Задайте проталкиваемую (Poke) величину', S) then
  begin
    S := S + #0;
    DataStr := @S[1];
    DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl,
      ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
    Request(ConvHdl);
  end;
end;
procedure TForm1.exit1Click(Sender: TObject);
begin
  close;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
{ После запроса обновляем окно. Рисуем график объема текущих продаж.}
const
  LMarg = 30; { Левое поле графика }
var
  I,
    Norm: Integer;
  Wd: Integer;
  Step: Integer;
  ARect: TRect;
begin
  Norm := 0;
  for I := Low(DataSample) to High(DataSample) do
  begin
    if abs(DataSample[I]) > Norm then
      Norm := abs(DataSample[I]);
  end; { for }
  if Norm = 0 then
    Norm := 1; { В случае если у нас все нули }
  with TPaintBox(Sender).Canvas do
  begin
    { Рисуем задний фон }
    Brush.color := clWhite;
    FillRect(ClipRect);
    { Рисуем ось }
    MoveTo(0, ClipRect.Bottom div 2);
    LineTo(ClipRect.Right, ClipRect.Bottom div 2);
    MoveTo(LMarg, 0);
    LineTo(LMarg, ClipRect.Bottom);
    { Печатаем текст левого поля }
    TextOut(0, 0, IntToStr(Norm));
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom div 2, '0');
    { Печатаем текст оси X }
    { Теперь рисуем бары на основе нормализованного значения.
    Вычисляем ширину баров (чтобы они все вместились в окне)
    и ширину пробела между ними, который приблизительно равен
    20% от их ширины. }
    {        SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));
    SetBkMode(PaintDC, Transparent);
    }
    ARect := ClipRect;
    Wd := (ARect.Right - LMarg) div NumValues;
    Step := Wd div 5;
    Wd := Wd - Step;
    with ARect do
    begin
      Left := LMarg + (Step div 2);
      Top := ClipRect.Bottom div 2;
    end; { with }
    { Выводим бары и текст для оси X }
    for i := Low(DataSample) to High(DataSample) do
    begin
      with ARect do
      begin
        Right := Left + Wd;
        Bottom := Top - Round((Top - 5) * (DataSample[I] / Norm));
      end; { with }
      { Заполняем бар }
      Brush.color := clFuchsia;
      FillRect(ARect);
      { Выводим текст для горизонтальной оси }
      Brush.color := clWhite;
      TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height,
        StrPas(DataItemNames[i]));
      with ARect do
        Left := Left + Wd + Step;
    end; { for }
  end; { with }
end;
end. { ***  КОНЕЦ КОДА DDEMLCLU.PAS *** }
{ *** НАЧАЛО КОДА DDEMLSVR.DPR *** }
program Ddemlsvr;
uses
  Forms,
  Ddesvru in 'DDESVRU.PAS' {Form1},
  Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};
{$R *.RES}
begin
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TDataEntry, DataEntry);
  Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLSVR.DPR *** }
{ *** НАЧАЛО КОДА DDESVRU.DFM *** }
object Form1: TForm1
  Left = 712
    Top = 98
    Width = 307
    Height = 162
    Caption = 'Демонстрация DDEML, Серверное приложение'
    Color = clWhite
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    Menu = MainMenu1
    PixelsPerInch = 96
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    OnShow = FormShow
    TextHeight = 16
    object Label1: TLabel
    Left = 0
      Top = 0
      Width = 99
      Height = 16
      Caption = 'Текущие значения:'
  end
  object Label2: TLabel
    Left = 16
      Top = 24
      Width = 74
      Height = 16
      Caption = 'Data Item1:'
  end
  object Label3: TLabel
    Left = 16
      Top = 40
      Width = 74
      Height = 16
      Caption = 'Data Item2:'
  end
  object Label4: TLabel
    Left = 16
      Top = 56
      Width = 74
      Height = 16
      Caption = 'Data Item3:'
  end
  object Label5: TLabel
    Left = 0
      Top = 88
      Width = 265
      Height = 16
      Caption = 'Выбор данных | Ввод данных для изменения значений.'
  end
  object Label6: TLabel
    Left = 96
      Top = 24
      Width = 8
      Height = 16
      Caption = '0'
  end
  object Label7: TLabel
    Left = 96
      Top = 40
      Width = 8
      Height = 16
      Caption = '0'
  end
  object Label8: TLabel
    Left = 96
      Top = 56
      Width = 8
      Height = 16
      Caption = '0'
  end
  object MainMenu1: TMainMenu
    Left = 352
      Top = 24
      object File1: TMenuItem
      Caption = '&Файл'
        object Exit1: TMenuItem
        Caption = '&Выход'
          OnClick = Exit1Click
      end
    end
    object Data1: TMenuItem
      Caption = '&Данные'
        object EnterData1: TMenuItem
        Caption = '&Ввод данных'
          OnClick = EnterData1Click
      end
      object Clear1: TMenuItem
        Caption = '&Очистить'
          OnClick = Clear1Click
      end
    end
  end
end
{ ***  КОНЕЦ КОДА DDESVRU.DFM *** }
{ *** НАЧАЛО КОДА DDESVRU.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}
{ Данный демонстрационный пример использует библиотеку DDEML
на стороне сервера кооперативного приложения. Данный сервер
является простым приложением для ввода данных и позволяет
оператору осуществлять ввод трех элементов данных, которые
становятся доступными через DDE "заинтересованным" клиентам.
Данный сервер предоставляет свои услуги (сервисы) для данных
со следующими именами:
Service: 'DataEntry'
Topic  : 'SampledData'
Items  : 'DataItem1', 'DataItem2', 'DataItem3'
В-принципе, в качестве сервисов могли бы быть определены
и другие темы. Полезными темами, на наш взгляд, могут быть
исторические даты, информация о сэмплах и пр..
Вы должны запустить этот сервер ПЕРЕД тем как запустите
клиента (DDEMLCLI.PAS), в противном случае клиент не
сможет установить связь.
Интерфейс для этого сервера определен как список имен
(Service, Topic и Items) в отдельном модуле с именем
DataEntry (DATAENTR.TPU). Сервер делает Items доступными
в формате cf_Text; они преобразовываются и хранятся у
клиента локально как целые. }
unit Ddesvru;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Menus,
  DDEML, { DDE APi }
  ShellApi;
const
  NumValues = 3;
  DataItemNames: array[1..NumValues] of PChar = ('DataItem1',
    'DataItem2',
    'DataItem3');
type
  TDataString = array[0..20] of Char; { Размер элемента как текста }
  TDataSample = array[1..NumValues] of Integer;
  {type
  { Структура данных, составляющих образец }
  {  TDataSample = array [1..NumValues] of Integer;
  {  TDataString = array [0..20] of Char;     { Размер элемента как текста }
const
  DataEntryName: PChar = 'DataEntry';
  DataTopicName: PChar = 'SampledData';
type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Exit1: TMenuItem;
    Data1: TMenuItem;
    EnterData1: TMenuItem;
    Clear1: TMenuItem;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    procedure Exit1Click(Sender: TObject);
    function MatchTopicAndService(Topic, Service: HSz): Boolean;
    function MatchTopicAndItem(Topic, Item: HSz): Integer;
    function WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
    function AcceptPoke(Item: HSz; ClipFmt: Word;
      Data: HDDEData): Boolean;
    function DataRequested(TransType: Word; ItemNum: Integer;
      ClipFmt: Word): HDDEData;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure EnterData1Click(Sender: TObject);
    procedure Clear1Click(Sender: TObject);
  private
    Inst: Longint;
    CallBack: TCallback;
    ServiceHSz: HSz;
    TopicHSz: HSz;
    ItemHSz: array[1..NumValues] of HSz;
    ConvHdl: HConv;
    Advising: array[1..NumValues] of Boolean;
    DataSample: TDataSample;
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
uses DDEDlg; { Форма DataEntry }
{$R *.DFM}
procedure TForm1.Exit1Click(Sender: TObject);
begin
  Close;
end;
{ Глобальная инициализация }
const
  DemoTitle: PChar = 'DDEML демо, серверное приложение';
  MaxAdvisories = 100;
  NumAdvLoops: Integer = 0;
  { Локальная функция: Процедура обратного вызова для DDEML }
  { Данная функция обратного вызова реагирует на все транзакции,
  генерируемые DDEML. Объект "target Window" (окно-цель)
  берется из глобально хранимых, и для реагирования на данную
  транзакцию, тип которой указан в параметре CallType,
  используются подходящие методы этих объектов.}
function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ;
  Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
var
  ItemNum: Integer;
begin
  CallbackProc := 0; { В противном случае смотрите доказательство }
  case CallType of
    xtyp_WildConnect:
      CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);
    xtyp_Connect:
      if Conv = 0 then
      begin
        if Form1.MatchTopicAndService(HSz1, HSz2) then
          CallbackProc := 1; { Связь! }
      end;
    { После подтверждения установки соединения записываем
    дескриптор связи как родительское окно.}
    xtyp_Connect_Confirm:
      Form1.ConvHdl := Conv;
    { Клиент запрашивает данные, делает прямой запрос или
    отвечает на уведомление. Возвращаем текущее состояние данных.}
    xtyp_AdvReq, xtyp_Request:
      begin
        ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
        if ItemNum > 0 then
          CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);
      end;
    { Отвечаем на Poke-запрос ... данная демонстрация допускает
    только Pokes для DataItem1. Для подтверждения получения
    запроса возвращаем dde_FAck, в противном случае 0.}
    xtyp_Poke:
      begin
        if Form1.AcceptPoke(HSz2, Fmt, Data) then
          CallbackProc := dde_FAck;
      end;
    { Клиент сделал запрос для старта цикла-уведомления.
    Имейте в виду, что мы организуем "горячий" цикл.
    Устанавливаем флаг Advising для указания открытого
    цикла, который будет проверять данные на предмет
    их изменения.}
    xtyp_AdvStart:
      begin
        ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
        if ItemNum > 0 then
        begin
          if NumAdvLoops < MaxAdvisories then
          begin { Произвольное число }
            Inc(NumAdvLoops);
            Form1.Advising[ItemNum] := True;
            CallbackProc := 1;
          end;
        end;
      end;
    { Клиент сделал запрос на прерывание цикла-уведомления.}
    xtyp_AdvStop:
      begin
        ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
        if ItemNum > 0 then
        begin
          if NumAdvLoops > 0 then
          begin
            Dec(NumAdvLoops);
            if NumAdvLoops = 0 then
              Form1.Advising[ItemNum] := False;
            CallbackProc := 1;
          end;
        end;
      end;
  end; { Case CallType }
end;
{ Возращает True, если данные Topic и Service поддерживаются
этим приложением. В противном случае возвращается False.}
function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;
begin
  Result := False;
  if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
    if DdeCmpStringHandles(ServiceHSz, Service) = 0 then
      Result := True;
end;
{ Определяем, один ли Topic и Item поддерживается этим
приложением. Возвращаем номер заданного элемента (Item Number)
(в пределах 1..NumValues), если он обнаружен, и ноль в
противном случае.}
function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;
var
  I: Integer;
begin
  Result := 0;
  if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
    for I := 1 to NumValues do
      if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then
        Result := I;
end;
{ Отвечаем на запрос wildcard-соединения (дословно -
дикая карта, шаблон). Такие запросы возникают всякий раз,
когда клиент пытается подключиться к серверу с сервисом
или именем топика, установленного в 0. Если сервер
обнаруживает использование такого рода шаблона, он
возвращает дескриптор массива THSZPair, содержащего
найденные по шаблону Service и Topic.}
function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
var
  TempPairs: array[0..1] of THSZPair;
  Matched: Boolean;
begin
  TempPairs[0].hszSvc := ServiceHSz;
  TempPairs[0].hszTopic := TopicHSz;
  TempPairs[1].hszSvc := 0; { 0-завершает список }
  TempPairs[1].hszTopic := 0;
  Matched := False;
  if (Topic = 0) and (Service = 0) then
    Matched := True { Шаблон обработан, элементов не найдено }
  else if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then
    Matched := True
  else if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then
    Matched := True;
  if Matched then
    WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs),
      0, 0, ClipFmt, 0)
  else
    WildConnect := 0;
end;
{ Принимаем и проталкиваем данные по просьбе клиента.
Для демонстрации этого способа используем только
значение DataItem1, изменяемое Poke.}
function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word;
  Data: HDDEData): Boolean;
var
  DataStr: TDataString;
  Err: Integer;
  TempSample: Integer;
begin
  if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and
    (ClipFmt = cf_Text) then
  begin
    DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);
    Val(DataStr, TempSample, Err);
    if IntToStr(TempSample) <> Label6.Caption then
    begin
      Label6.Caption := IntToStr(TempSample);
      DataSample[1] := TempSample;
      if Advising[1] then
        DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
    end;
    AcceptPoke := True;
  end
  else
    AcceptPoke := False;
end;
{ Возвращаем данные, запрашиваемые значениями TransType
и ClipFmt. Такое может произойти в ответ на просьбу
xtyp_Request или xtyp_AdvReq. Параметр ItemNum указывает
на поддерживаемый (в диапазоне 1..NumValues) и требуемый
элемент (обратите внимание на то, что данный метод
подразумевает, что вызывающий оператор уже установил
достоверность и ID требуемого пункта с помощью
MatchTopicAndItem). Соответствующие данные из переменной
экземпляра DataSample преобразуются в текст и возвращаются
клиенту.}
function TForm1.DataRequested(TransType: Word; ItemNum: Integer;
  ClipFmt: Word): HDDEData;
var
  ItemStr: TDataString; { Определено в DataEntry.TPU }
begin
  if ClipFmt = cf_Text then
  begin
    Str(DataSample[ItemNum], ItemStr);
    DataRequested := DdeCreateDataHandle(Inst, @ItemStr,
      StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
  end
  else
    DataRequested := 0;
end;
{ Создаем экземпляр окна DDE сервера. Вызываем унаследованный
конструктор, затем устанавливаем эти объекты родителями
экземпляров данных. }
procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
  @CallBack := nil; { MakeProcInstance вызывается из SetupWindow         }
  for I := 1 to NumValues do
  begin
    DataSample[I] := 0;
    Advising[I] := False;
  end; { for }
end;
{ Разрушаем экземпляр окна DDE сервера. Проверяем, был ли
создан экземпляр процедуры обратного вызова, если он существует.
Также, для завершения диалога, вызовите DdeUninitialize.
Затем, для завершения работы, вызовите разрушителя предка.}
procedure TForm1.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  if ServiceHSz <> 0 then
    DdeFreeStringHandle(Inst, ServiceHSz);
  if TopicHSz <> 0 then
    DdeFreeStringHandle(Inst, TopicHSz);
  for I := 1 to NumValues do
    if ItemHSz[I] <> 0 then
      DdeFreeStringHandle(Inst, ItemHSz[I]);
  if Inst <> 0 then
    DdeUninitialize(Inst); { Игнорируем возвращаемое значение }
  if @CallBack <> nil then
    FreeProcInstance(@CallBack);
end;
procedure TForm1.FormShow(Sender: TObject);
var
  I: Integer;
  { Завершаем инициализацию окна DDE сервера. Процедура инициализации
  использует DDEML для регистрации сервисов, предусмотренных данным
  приложением. Помните о том, что реальные имена, использованные в
  регистрах, определены в отдельном модуле (DataEntry), поэтому они
  могут быть использованы и клиентом. }
begin
  @CallBack := MakeProcInstance(@CallBackProc, HInstance);
  if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then
  begin
    ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
    TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
    for I := 1 to NumValues do
      ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
        cp_WinAnsi);
    if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0 then
      ShowMessage('Ошибка в процессе регистрации.');
  end;
end;
procedure TForm1.EnterData1Click(Sender: TObject);
{ Активизируем диалог ввода данных и обновляем
хранимые данные по окончании ввода.}
var
  I: Integer;
begin
  if DataEntry.ShowModal = mrOk then
  begin
    with DataEntry do
    begin
      Label6.Caption := S1;
      Label7.Caption := S2;
      Label8.Caption := S3;
      DataSample[1] := StrToInt(S1);
      DataSample[2] := StrToInt(S2);
      DataSample[3] := StrToInt(S3);
    end; { with }
    for I := 1 to NumValues do
      if Advising[I] then
        DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
  end; { if }
end;
procedure TForm1.Clear1Click(Sender: TObject);
{ Очищаем текущую дату. }
var
  I: Integer;
begin
  for I := 1 to NumValues do
  begin
    DataSample[I] := 0;
    if Advising[I] then
      DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
  end;
  Label6.Caption := '0';
  Label7.Caption := '0';
  Label8.Caption := '0';
end;
end.
{ ***  КОНЕЦ КОДА DDESVRU.PAS *** }
{ *** НАЧАЛО КОДА DDEDLG.DFM *** }
object DataEntry: TDataEntry
  Left = 488
    Top = 132
    ActiveControl = OKBtn
    BorderStyle = bsDialog
    Caption = 'Ввод данных'
    ClientHeight = 264
    ClientWidth = 199
    Font.Color = clBlack
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = [fsBold]
    PixelsPerInch = 96
    Position = poScreenCenter
    OnShow = FormShow
    TextHeight = 13
    object Bevel1: TBevel
    Left = 8
      Top = 8
      Width = 177
      Height = 201
      Shape = bsFrame
      IsControl = True
  end
  object OKBtn: TBitBtn
    Left = 16
      Top = 216
      Width = 69
      Height = 39
      Caption = '&OK'
      ModalResult = 1
      TabOrder = 3
      OnClick = OKBtnClick
      Glyph.Data = {
    BE060000424DBE06000000000000360400002800000024000000120000000100
    0800000000008802000000000000000000000000000000000000000000000000
    80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
    A600000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303
    0303030303030303030303030303030303030303030303030303030303030303
    03030303030303030303030303030303030303030303FF030303030303030303
    03030303030303040403030303030303030303030303030303F8F8FF03030303
    03030303030303030303040202040303030303030303030303030303F80303F8
    FF030303030303030303030303040202020204030303030303030303030303F8
    03030303F8FF0303030303030303030304020202020202040303030303030303
    0303F8030303030303F8FF030303030303030304020202FA0202020204030303
    0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
    040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
    03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
    FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
    0303030303030303030303FA0202020403030303030303030303030303F8FF03
    03F8FF03030303030303030303030303FA020202040303030303030303030303
    0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303
    03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
    030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
    0202040303030303030303030303030303F8FF03F8FF03030303030303030303
    03030303FA0202030303030303030303030303030303F8FFF803030303030303
    030303030303030303FA0303030303030303030303030303030303F803030303
    0303030303030303030303030303030303030303030303030303030303030303
    0303}
    Margin = 2
      NumGlyphs = 2
      Spacing = -1
      IsControl = True
  end
  object CancelBtn: TBitBtn
    Left = 108
      Top = 216
      Width = 69
      Height = 39
      Caption = '&Отмена'
      TabOrder = 4
      Kind = bkCancel
      Margin = 2
      Spacing = -1
      IsControl = True
  end
  object Panel2: TPanel
    Left = 16
      Top = 88
      Width = 153
      Height = 49
      BevelInner = bvLowered
      BevelOuter = bvNone
      TabOrder = 1
      object Label1: TLabel
      Left = 24
        Top = 8
        Width = 5
        Height = 13
    end
    object Label2: TLabel
      Left = 8
        Top = 8
        Width = 48
        Height = 13
        Caption = 'Значение 2:'
    end
    object Edit2: TEdit
      Left = 8
        Top = 24
        Width = 121
        Height = 20
        MaxLength = 10
        TabOrder = 0
        Text = '0'
    end
  end
  object Panel1: TPanel
    Left = 16
      Top = 16
      Width = 153
      Height = 49
      BevelInner = bvLowered
      BevelOuter = bvNone
      TabOrder = 0
      object Label4: TLabel
      Left = 8
        Top = 8
        Width = 48
        Height = 13
        Caption = 'Значение 1:'
    end
    object Edit1: TEdit
      Left = 8
        Top = 24
        Width = 121
        Height = 20
        MaxLength = 10
        TabOrder = 0
        Text = '0'
    end
  end
  object Panel3: TPanel
    Left = 16
      Top = 144
      Width = 153
      Height = 49
      BevelInner = bvLowered
      BevelOuter = bvNone
      TabOrder = 2
      object Label6: TLabel
      Left = 8
        Top = 8
        Width = 48
        Height = 13
        Caption = 'Значение 3:'
    end
    object Edit3: TEdit
      Left = 8
        Top = 24
        Width = 121
        Height = 20
        MaxLength = 10
        TabOrder = 0
        Text = '0'
    end
  end
end
{ ***   КОНЕЦ КОДА DDEDLG.DFM *** }
{ *** НАЧАЛО КОДА DDEDLG.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}
{ Данный модуль определяет интерфейс сервера DataEntry DDE
(DDEMLSRV.PAS). Здесь определены имена Service, Topic,
и Item, поддерживаемые сервером, и также определена
структура данных, которая может использоваться
клиентом для локального хранения "показательных" данных.
Сервер Data Entry Server делает свои "показательные"
данные доступными в текстовом виде (cf_Text)
сформированными в виде трех различных топика (Topics).
Клиент может их преобразовывать в целое для
использования со структурой данных, которая здесь определена.
}
unit Ddedlg;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  StdCtrls, Mask, ExtCtrls;
type
  TDataEntry = class(TForm)
    OKBtn: TBitBtn;
    CancelBtn: TBitBtn;
    Bevel1: TBevel;
    Panel2: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Panel1: TPanel;
    Label4: TLabel;
    Panel3: TPanel;
    Label6: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    procedure OKBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    S1, S2, S3: string;
    { Public declarations }
  end;
var
  DataEntry: TDataEntry;
implementation
{$R *.DFM}
procedure TDataEntry.OKBtnClick(Sender: TObject);
begin
  S1 := Edit1.Text;
  S2 := Edit2.Text;
  S3 := Edit3.Text;
end;
procedure TDataEntry.FormShow(Sender: TObject);
begin
  Edit1.Text := '0';
  Edit2.Text := '0';
  Edit3.Text := '0';
  Edit1.SetFocus;
end;
end.
{ ***  КОНЕЦ КОДА DDEDLG.PAS *** }

DDE - передача текста.

Вот я как работаю с Excel:

type
  DDEClientConv1.SetLink('Excel', 'Sheet1');
try
  DDEClientConv1.OpenLink;
  DDEClientItem1.DDEItem := 'R1C1';
  DDEClientConv1.PokeData(DDEClientItem1.DDEItem,
    StrPCopy(P, SomeString)));
finally
  DDEClientConv1.CloseLink;
end;

Как вы можете здесь видеть, свойство DDEItem определяется сервером. Если ваш сервер является приложением Delphi, то DDEItem - имя DDEServerItem. На вашем месте я бы не стал так долго заниматься отладкой DDE-программ. Воспользуйтесь синхронизацией, позволяющей понять при отладке правильность действий.

DDE для захвата текущего URL из окна Internet Explorer или Netscape Navigator.

uses
  windows, ddeman, ...
function Get_URL(Servicio: string): string;
var
  Cliente_DDE: TDDEClientConv;
  temp: PChar;      //
begin
  Result := '';
  Cliente_DDE:= TDDEClientConv.Create( nil );
  with Cliente_DDE do
  begin
    SetLink( Servicio,'WWW_GetWindowInfo');
    temp := RequestData('0xFFFFFFFF');
    Result := StrPas(temp);
    StrDispose(temp);  // 
    CloseLink;
  end;
  Cliente_DDE.Free;
end;
procedure TForm1.Button1Click(Sender);
begin
   showmessage(Get_URL('Netscape'));
// или
   showmessage(Get_URL('IExplore'));
end;

DDE.

Оформил: DeeCo

procedure TDdeSrvrForm.doMacro(Sender: TObject;
  Msg: TStrings);
var
  Text: string;
begin
  Text := '';
  if Msg.Count >
  0 then
    Text := Msg.Strings[0];
  MessageDlg('Executing Macro - ' + Text, mtInformation,
    [mbOK], 0);
end;

procedure TDdeSrvrForm.doOnChange(Sender: TObject);
begin
  if not FInPoke then
    DdeTestItem.Lines := Edit1.Lines;
end;

procedure TDdeSrvrForm.doOnPoke(Sender: TObject);
begin
  FInPoke := True;
  Edit1.Lines := DdeTestItem.Lines;
  FInPoke := False;
end;

procedure TFormD.doNewLink(Sender: TObject);
begin
  DdeClient.SetLink(AppName.Text, TopicName.Text);
  DdeClientItem.DdeConv := DdeClient;
  DdeClientItem.DdeItem := ItemName.Text;
end;

procedure TFormD.doPasteLink(Sender: TObject);
var
  Service, Topic, Item: string;
begin
  if GetPasteLinkInfo(Service, Topic, Item) then
  begin
    AppName.Text := Service;
    TopicName.Text := Topic;
    ItemName.Text := Item;
    DdeClient.SetLink(Service, Topic);
    DdeClientItem.DdeConv := DdeClient;
    DdeClientItem.DdeItem := ItemName.Text;
  end;
end;

procedure TFormD.DdeClientItemChange(Sender: TObject);
begin
  DdeDat.Lines := DdeClientItem.Lines;
end;

procedure TFormD.doMacro(Sender: TObject);
begin
  DdeClient.ExecuteMacroLines(XEdit.Lines, True);
end;

procedure TFormD.doPoke(Sender: TObject);
begin
  DdeClient.PokeDataLines(DdeClientItem.DdeItem, XEdit.Lines);
end;

Регистрация программ в меню Пуск Windows95.

Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь - использование DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов - объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:

function TForm2.ProgmanCommand(Command: string): boolean;
var
  macrocmd: array[0..88] of char;
begin
  DDEClient.SetLink('PROGMAN', 'PROGMAN');
  DDEClient.OpenLink; { Устанавливаем связь по DDE }
  strPCopy(macrocmd, '[' + Command + ']'); { Подготавливаем ASCIIZ строку }
  ProgmanCommand := DDEClient.ExecuteMacro(MacroCmd, false);
  DDEClient.CloseLink; { Закрываем связь по DDE }
end;
// Пример использования:
ProgmanCommand('CreateGroup(Комплекс программ для
  каталогизации литературы, )');
ProgmanCommand('AddItem(' + path + 'vbase.hlp, Справка по VBase,
  '+ path +' vbase.hlp, 0, , , '+ path + ', , )');
// где path - строка типа String, содержащая
// полный путь к каталогу ('C:\Catalog\');

При вызове ProgmanCommand возвращает true, если посылка макроса была успешна. Система команд (основных) приведена ниже:

DDE для вызова диалога поиска файлов и папок.

uses DdeMan;
procedure TForm1.Button1Click(Sender: TObject);
begin
  with TDDEClientConv.Create(Self) do
  begin
    ConnectMode := ddeManual;
    ServiceApplication := 'explorer.exe';
    SetLink( 'Folders', 'AppProperties');
    OpenLink;
    ExecuteMacro('[FindFolder(, C:\Мои документы)]', False);
    CloseLink;
    Free;
  end;
end;

Пример DDE и WordPerfect.

Вот небольшой пример, скопированный из моего проекта:

procedure TForm1.PrintSave(Doc: string);
var
  ProdDoc, ArchDoc: string;
  WPCommands: TStringList;
begin
  ProdDoc := ProdDrive + Doc;
  ArchDoc := ArchDrive + Doc;
  WPCommands := TStringList.Create;
  with WPCommands do
  begin
    Add('FileOpen(Filename:"' + ProdDoc + '")');
    Add('FileSave(Filename:"' + ProdDoc + '";ExportType:3;Overwrite:1)');
    Add('PrintCopies(NumberOfCopies:2)');
    Add('PrintCopiesBy(CopiesBy:1) ');
    Add('PrintFullDoc() ');
    Add('DocCompare(FileName:"' + ArchDoc + '";CompFlags:1) ');
    Add('FileSave(Filename:"' + EMailDoc + '";ExportType:3;Overwrite:1');
    Add('Close(Save:0) ');
  end;
  if PDDE.ExecuteMacroLines(WPCommands, True) then
  begin
    log('WPCommand Worked!')
      {  Теперь необходимо подождать WP, чтобы завершить команду... }
  end
  else
    log('Ошибка WPCommand!');
  WPCommands.Free;
end;

Все это проверено, DDE работает в связке WP/Delphi, первая команда возвращает сообщение 'Ok, я получил это', и запускает макрос. При попытке послать второй запрос DDE, он ожидает завершение обработки первого, выводит сообщение типа 'Необходимо подождать....', после чего немедленно передает управление. Мне хотелось бы дождаться команды завершения прежде, чем я возвращусь из своей процедуры.

Работа с Netscape Navigator через DDE.

uses DDEman;
...
procedure GotoURL(sURL: string);
var
  dde: TDDEClientConv;
begin
  dde := TDDEClientConv.Create(nil);
  with dde do
  begin
    // specify the location of netscape.exe
    ServiceApplication :='C:\Program Files\Netscape\Communicator\Program\NETSCAPE.EXE';
    // activate the Netscape Navigator
    SetLink( 'Netscape', 'WWW_Activate' );
    RequestData('0xFFFFFFFF');
    // go to the specified URL
    SetLink( 'Netscape', 'WWW_OpenURL' );
    RequestData( sURL+',,0xFFFFFFFF,0x3,,,' );
    // ... CloseLink;
  end;
  dde.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  GotoURL('http://www.site.ru');
end;

Деактивация приложения.

Если вы хотите что-то сделать когда ваше приложение теряет фокус, используйте обработчик события Application.onDeactivate. Добавьте следующую строку в обработчик формы FormCreate:

Application.OnDeactivate=AppDeactivate; 

Затем создайте следующий метод:

procedure Form1.AppDeactivate(Sender: TObject);
begin
  ...
  { здесь ваш код}
  ...
end;

Набор данных для отладки.

unit DebugSet;
interface
uses
  DbTables, Classes, Controls, Db, SysUtils;
type
  TDebugNotify = procedure(const DegubStr: string) of object;
  TDebugDataSet = class(TTable)
  private
    FDebugNotify: TDebugNotify;
  protected
    // TDataSet virtual abstract methods
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar;
      Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar):
      TBookmarkFlag; override;
    function GetFieldData(Field: TField;
      Buffer: Pointer): Boolean; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure InternalAddRecord(Buffer: Pointer;
      Append: Boolean); override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(
      Bookmark: Pointer); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    procedure SetBookmarkFlag(Buffer: PChar;
      Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar;
      Data: Pointer); override;
    procedure SetFieldData(Field: TField;
      Buffer: Pointer); override;
    // TDataSet virtual methods (optional)
    procedure InternalRefresh; override;
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
  public
    property OnDebugNotify: TDebugNotify
      read FDebugNotify write FDebugNotify;
  end;
implementation
procedure TDebugDataSet.InternalOpen;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalOpen');
  inherited;
end;
procedure TDebugDataSet.InternalInitFieldDefs;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalInitFieldDefs');
  inherited;
end;
procedure TDebugDataSet.InternalClose;
begin
  FDebugNotify('InternalClose');
  inherited;
end;
function TDebugDataSet.IsCursorOpen: Boolean;
begin
  Result := inherited IsCursorOpen;
  if Result then
    if Assigned(FDebugNotify) then
      FDebugNotify('IsCursorOpen: True')
    else if Assigned(FDebugNotify) then
      FDebugNotify('IsCursorOpen: False');
end;
procedure TDebugDataSet.InternalGotoBookmark(Bookmark: Pointer);
begin
  FDebugNotify('InternalGotoBookmark' +
    IntToStr(Integer(Bookmark)));
  inherited;
end;
procedure TDebugDataSet.InternalSetToRecord(Buffer: PChar);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalSetToRecord');
  inherited;
end;
function TDebugDataSet.GetBookmarkFlag(
  Buffer: PChar): TBookmarkFlag;
begin
  FDebugNotify('GetBookmarkFlag');
  Result := inherited GetBookmarkFlag(Buffer);
end;
procedure TDebugDataSet.SetBookmarkFlag(Buffer: PChar;
  Value: TBookmarkFlag);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetBookmarkFlag');
  inherited;
end;
procedure TDebugDataSet.GetBookmarkData(
  Buffer: PChar; Data: Pointer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('GetBookmarkData');
  inherited;
end;
procedure TDebugDataSet.SetBookmarkData(
  Buffer: PChar; Data: Pointer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetBookmarkData');
  inherited;
end;
function TDebugDataSet.GetRecordSize: Word;
begin
  Result := inherited GetRecordSize;
  if Assigned(FDebugNotify) then
    FDebugNotify('GetRecordSize: ' + IntToStr(Result));
end;
function TDebugDataSet.AllocRecordBuffer: PChar;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('AllocRecordBuffer');
  Result := inherited AllocRecordBuffer;
end;
procedure TDebugDataSet.InternalInitRecord(Buffer: PChar);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalInitRecord');
  inherited;
end;
procedure TDebugDataSet.FreeRecordBuffer(var Buffer: PChar);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('FreeRecordBuffer');
  inherited;
end;
function TDebugDataSet.GetRecord(Buffer: PChar;
  GetMode: TGetMode; DoCheck: Boolean): TGetResult;
begin
  case GetMode of
    gmNext:
      if Assigned(FDebugNotify) then
        FDebugNotify('GetRecord: Next');
    gmPrior:
      if Assigned(FDebugNotify) then
        FDebugNotify('GetRecord: Prior');
    gmCurrent:
      if Assigned(FDebugNotify) then
        FDebugNotify('GetRecord: Current');
  end;
  Result := inherited GetRecord(Buffer, GetMode, DoCheck);
end;
procedure TDebugDataSet.InternalFirst;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalFirst');
  inherited;
end;
procedure TDebugDataSet.InternalLast;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalLast');
  inherited;
end;
procedure TDebugDataSet.InternalPost;
begin
  if State = dsEdit then
    if Assigned(FDebugNotify) then
      FDebugNotify('InternalPost ***** dsEdit')
    else if Assigned(FDebugNotify) then
      FDebugNotify('InternalPost ***** dsInsert');
  inherited;
end;
procedure TDebugDataSet.InternalAddRecord(
  Buffer: Pointer; Append: Boolean);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalAddRecord ****');
  inherited;
end;
procedure TDebugDataSet.InternalDelete;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalDelete');
  inherited;
end;
function TDebugDataSet.GetFieldData(
  Field: TField; Buffer: Pointer): Boolean;
begin
  Result := inherited GetFieldData(Field, Buffer);
end;
procedure TDebugDataSet.SetFieldData(Field: TField; Buffer: Pointer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetFieldData');
  inherited;
end;
function TDebugDataSet.GetRecordCount: Longint;
begin
  Result := inherited GetRecordCount;
  if Assigned(FDebugNotify) then
    FDebugNotify('GetRecordCount: ' + IntToStr(Result));
end;
function TDebugDataSet.GetRecNo: Longint;
begin
  Result := inherited GetRecNo;
  if Assigned(FDebugNotify) then
    FDebugNotify('GetRecNo: ' + IntToStr(Result));
end;
procedure TDebugDataSet.SetRecNo(Value: Integer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetRecNo: ' + IntToStr(Value));
  inherited;
end;
procedure TDebugDataSet.InternalRefresh;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalRefresh');
  inherited;
end;
procedure TDebugDataSet.InternalHandleException;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalHandleException');
  inherited;
end;
end.

unit DebugDSForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, DebugSet, Grids, DBGrids, DBCtrls, ExtCtrls,
  StdCtrls, Db, DBTables, Menus;
type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    ListBox1: TListBox;
    Splitter1: TSplitter;
    Panel1: TPanel;
    DBNavigator1: TDBNavigator;
    DBGrid1: TDBGrid;
    Panel2: TPanel;
    BtnOpen: TButton;
    BtnClose: TButton;
    BtnClear: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BtnClearClick(Sender: TObject);
    procedure BtnOpenClick(Sender: TObject);
    procedure BtnCloseClick(Sender: TObject);
  private
    TableClone: TDebugDataSet;
  public
    procedure LocalNotify(const DebugText: string);
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
  Table1.Close;
  TableClone := TDebugDataSet.Create(nil);
  TableClone.DatabaseName := Table1.DatabaseName;
  TableClone.TableName := Table1.TableName;
  TableClone.OnDebugNotify := LocalNotify;
  DataSource1.DataSet := TableClone;
end;
procedure TForm1.LocalNotify(const DebugText: string);
var
  nItem: Integer;
begin
  if Assigned(ListBox1) then
  begin
    // add the text to the string
    nItem := ListBox1.Items.Add(DebugText);
    // select the new item
    ListBox1.ItemIndex := nItem;
  end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  TableClone.Close;
  TableClone.Free;
end;
procedure TForm1.BtnClearClick(Sender: TObject);
begin
  ListBox1.Items.Clear;
end;
procedure TForm1.BtnOpenClick(Sender: TObject);
begin
  TableClone.Active := True;
end;
procedure TForm1.BtnCloseClick(Sender: TObject);
begin
  TableClone.Active := False;
end;
end.

В режиме отладки приложения не разрешается открытие базы данных.

Глюк имеет место быть только под Windows NT 4.xx.

Крах отладчика при передаче параметров.

Оформил: DeeCo

Автор: Александр Малыгин.

type
  TBTZ = packed record
    case integer of
      0: (BTZ1: array[0..6] of byte;
        BTZ2: array[0..1] of byte;
        BTZ3: array[0..1] of byte;
        BTZ4: array[0..2] of byte);
      1: (BTZW, BTZH: array[0..6] of byte);
      2: (BTZ: array[0..13] of byte);
  end;
  TPrmTS = packed record
    PrmC, PrmN: array[0..3] of TBTZ;
  end;
procedure Stone(var P: TPrmTS);
begin
  // ...
end;

РЕШЕНИЕ: Передавать проблемный тип как нетипизированный var-параметр.

Определение и использование курсора.

Сначала (поскольку многие попадаются в эту ловушку) убедитесь в том, что имя .RES-файла, в котором вы храните ваш курсор, отличается от имени .RES-файла вашего проекта, т.е., если ваш проект имеет имя MyApp.DPR, то не используйте для хранения новых ресурсов файл MyApp.RES. Вы должны создать отдельный .RES-файл с другим именем (например, MyApp01.RES) и включить его в ваш проект, например так:

implementation
{$R MyApp01.Res}

Для начала определите константу, допустим так:

Const
  MyCursor = 1;

Далее необходимо загрузить курсор. Сделать это можно в обработчике события формы OnCreate:

Screen.Cursors[MyCursor] := LoadCursor(HInstance, 'MYCURSOR');

Затем просто установите в свойстве DragCursor любого элемента управления:

MyListbox.DragCursor := MyCursor;

Примечание: имя вашего курсора всегда должно писаться в ВЕРХНЕМ регистре, как при вызове LoadCursor, так и в его названии в .RES-файле.

Определение присутствия функции в DLL.

Данная функция определяет присутствие нужной функции в библиотеке (dll) и, в случае нахождения искомой функции возвращает True, иначе False.

function FuncAvail (VLibraryname, VFunctionname: string;
         var VPointer: pointer): boolean;
var
  Vlib: tHandle;
begin
  Result := false;
  VPointer := nil;
  if LoadLibrary(PChar(VLibraryname)) = 0 then
    exit;
  VPointer := GetModuleHandle(PChar(VLibraryname));
  if Vlib <> 0 then
  begin
    VPointer := GetProcAddress(Vlib, PChar(VFunctionname));
    if VPointer <> nil then
      Result := true;
  end;
end;

Декларация события OnPassword.

Решение B немного более прагматичное и не требует изменения исходного кода VCL. Создайте следующую функцию:

procedure PasswordProc(Sender: TObject; var Continue: Boolean); far;
begin
  Session.AddPassword('Harrison');
  Continue := True;
end;

Затем измените обработчик события OnCreate...

procedure TForm1.FormCreate(Sender: TObject);
begin
  Session.OnPassword := PasswordProc;
  Table1.Active := True;
end;

Если вы решаете воспользоваться методом A, то единственное отличие будет заключаться в том, что вам понадобиться добавить объявление процедуры к вашему классу формы, и в секции Implementation ваша процедура должна выглядеть примерно так:

procedure TForm1.PasswordProc(Sender: TObject; var Continue: Boolean);
begin
  Session.AddPassword('Harrison');
  Continue := True;
end;

Поскольку эта версия является функцией-членом, у нее существует преимущество при доступе к компонентам и private- или protected-членам вашей формы (TForm-производного класса).

Декомпиляция в Delphi.

Читая форумы по программированию, иногда натыкаешься на вопрос типа: "У меня есть откомпилированная программа на Delphi. Как мне получить её исходный код?". Обычно такой вопрос возникает, когда программист потерял файлы проекта и у него остался только .exe. Как правило полностью восстановить исходный код на языке высокого уровня невозможно. Значит ли это, что другие тоже не смогут восстановить исходный код Вашей программы ? Хм ... и да и нет ...

Для начала сразу скажу, что восстановить исходный код в точности каким он был однозначно невозможно, так как не существует в мире такого декомпилятора, который бы смог сотворить такое.

После компиляции и линковки проекта и получения исполняемого файла все имена, используемые в программе конвертируются в адреса. Потеря имён означет, что декомпилятор создаст уникальное имя для каждой константы, переменной, функции и процедуры. Даже если мы и достигнем какого-то успеха в декомпиляции исполняемого файла, то получим уже другой синтаксис программы. Данная проблема связана с тем, что при компиляции практически идентичные куски кода могут быть скомпилированы в разные последовательности машинных команд (ASM), которые присутствуют в .exe файле. Естевственно декомпилятор не обладает такой степенью интеллектуальности, чтобы решить - какова же была последовательность инструкций языка высокого уровня в исходном проекте.

Когда же применяется декомпиляция ? Для этого существует довольно много причин. Вот некторые из них:

Легально ли всё это? Хотя декомпиляция и не является взломом, но утвердительно ответить на этот вопрос довольно сложно. Обычно программы защищены законом об авторских правах, однако в большинстве стран на декомпиляцию делается исключение. В часности, когда необходимо изменить интерфейс программы для конкретной страны, а сервис приложения не позволяет этого сделать.

На данный момент Borland не предоставляет никаких программных продуктов, способных декомпилировать исполняемые файлы (.exe) либо откомпилированные Delphi-модули (.dcu) в исходный код (.pas).

Если же Вы всё-таки решились попробовать декомпилировать исполняемый файл, то необходимо знать следующие вещи. Исходные коды на Delphi обычно хранятся в файлах двух типов: сам исходник в ASCII кодировке (.pas, .dpr) и файлы ресурсов (.res, .rc, .dfm, .dcr). Dfm файлы хранят в себе свойства объектов, содержащихся в форме. При создании конечного .exe, Delphi копирует в него информацию из .dfm файлов. Каждый раз, когда мы изменяем координаты формы, описания кнопок или связанные с ними события, то Delphi записывает эти изменения в .dfm (за исключением кода процедур. Он сохраняется в файлах pas/dcu ). И наконец, чтобы получить при декомпиляции файл .dfm, нужно знать - какие типы ресурсов хранятся внутри Win32 исполняемого модуля.

Все программы, скомпилированные в Delphi имеют следующие секции: CODE, DATA, BSS, .idata, tls, .rdata, .rsrc. Самые важные для декомпиляции секции CODE и .rsrc. В статье "Adding functionality to a Delphi program" приведены некоторые интересные факты о исполняемых форматах Delphi, а так же информация о классах и DFM ресурсах. В этой статье есть один интересный момент под заголовком: "Как добавить свой обработчик события в уже откомпилированный файл, например, чтобы изменять тект на кнопке".

Среди многих типов ресурсов, которые сохранены в .exe файле, интерес представляет RT_RCDATA, который хранит информацию, которая были в DFM файле перед трансляцией. Чтобы извлеч DFM данные из .exe файла, мы можем вызываться API функцией EnumResourceNames.

Исскуство декомпилирования традиционно было уделом мастеров, знакомых с ассемблером и отладчиками. Некоторые Delphi декомпиляторы создают впечатление, что любой, даже с ограниченными техническими знаниями, может изменить по своему желанию большинство исполняемых файлов Delphi.

И в заключение, если Вы заинтересовались декомпилованием, то предлагаю Вам несколько Delphi декомпиляторов:

Декомпилляция звукового файла формата Wave и получение звуковых данных.

Интересно, есть ли технология преобразования Wave-формата в обычный набор звуковых данных? К примеру, мне необходимо удалить заголовок и механизм (метод) сжатия, которые могут компилироваться и сохраняться вместе с Wave-файлами.

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.

unit LinearSystem;
interface
{============== Тип, описывающий формат WAV ==================}
type
  WAVHeader = record
    nChannels: Word;
    nBitsPerSample: LongInt;
    nSamplesPerSec: LongInt;
    nAvgBytesPerSec: LongInt;
    RIFFSize: LongInt;
    fmtSize: LongInt;
    formatTag: Word;
    nBlockAlign: LongInt;
    DataSize: LongInt;
  end;
  {============== Поток данных сэмпла ========================}
const
  MaxN = 300; { максимальное значение величины сэмпла }
type
  SampleIndex = 0..MaxN + 3;
type
  DataStream = array[SampleIndex] of Real;
var
  N: SampleIndex;
  {============== Переменные сопровождения ======================}
type
  Observation = record
    Name: string[40]; {Имя данного сопровождения}
    yyy: DataStream; {Массив указателей на данные}
    WAV: WAVHeader; {Спецификация WAV для сопровождения}
    Last: SampleIndex; {Последний доступный индекс yyy}
    MinO, MaxO: Real; {Диапазон значений yyy}
  end;
var
  K0R, K1R, K2R, K3R: Observation;
  K0B, K1B, K2B, K3B: Observation;
  {================== Переменные имени файла ===================}
var
  StandardDatabase: string[80];
  BaseFileName: string[80];
  StandardOutput: string[80];
  StandardInput: string[80];
  {=============== Объявления процедур ==================}
procedure ReadWAVFile(var Ki, Kj: Observation);
procedure WriteWAVFile(var Ki, Kj: Observation);
procedure ScaleData(var Kk: Observation);
procedure InitAllSignals;
procedure InitLinearSystem;
implementation
{$R *.DFM}
uses VarGraph, SysUtils;
{================== Стандартный формат WAV-файла ===================}
const
  MaxDataSize: LongInt = (MaxN + 1) * 2 * 2;
const
  MaxRIFFSize: LongInt = (MaxN + 1) * 2 * 2 + 36;
const
  StandardWAV: WAVHeader = (
    nChannels: Word(2);
    nBitsPerSample: LongInt(16);
    nSamplesPerSec: LongInt(8000);
    nAvgBytesPerSec: LongInt(32000);
    RIFFSize: LongInt((MaxN + 1) * 2 * 2 + 36);
    fmtSize: LongInt(16);
    formatTag: Word(1);
    nBlockAlign: LongInt(4);
    DataSize: LongInt((MaxN + 1) * 2 * 2)
    );
  {================== Сканирование переменных сопровождения ===================}
procedure ScaleData(var Kk: Observation);
var
  I: SampleIndex;
begin
  {Инициализация переменных сканирования}
  Kk.MaxO := Kk.yyy[0];
  Kk.MinO := Kk.yyy[0];
  {Сканирование для получения максимального и минимального значения}
  for I := 1 to Kk.Last do
  begin
    if Kk.MaxO < Kk.yyy[I] then
      Kk.MaxO := Kk.yyy[I];
    if Kk.MinO > Kk.yyy[I] then
      Kk.MinO := Kk.yyy[I];
  end;
end; { ScaleData }
procedure ScaleAllData;
begin
  ScaleData(K0R);
  ScaleData(K0B);
  ScaleData(K1R);
  ScaleData(K1B);
  ScaleData(K2R);
  ScaleData(K2B);
  ScaleData(K3R);
  ScaleData(K3B);
end; {ScaleAllData}
{================== Считывание/запись WAV-данных ===================}
var
  InFile, OutFile: file of Byte;
type
  Tag = (F0, T1, M1);
type
  FudgeNum = record
    case X: Tag of
      F0: (chrs: array[0..3] of Byte);
      T1: (lint: LongInt);
      M1: (up, dn: Integer);
  end;
var
  ChunkSize: FudgeNum;
procedure WriteChunkName(Name: string);
var
  i: Integer;
  MM: Byte;
begin
  for i := 1 to 4 do
  begin
    MM := ord(Name[i]);
    write(OutFile, MM);
  end;
end; {WriteChunkName}
procedure WriteChunkSize(LL: Longint);
var
  I: integer;
begin
  ChunkSize.x := T1;
  ChunkSize.lint := LL;
  ChunkSize.x := F0;
  for I := 0 to 3 do
    Write(OutFile, ChunkSize.chrs[I]);
end;
procedure WriteChunkWord(WW: Word);
var
  I: integer;
begin
  ChunkSize.x := T1;
  ChunkSize.up := WW;
  ChunkSize.x := M1;
  for I := 0 to 1 do
    Write(OutFile, ChunkSize.chrs[I]);
end; {WriteChunkWord}
procedure WriteOneDataBlock(var Ki, Kj: Observation);
var
  I: Integer;
begin
  ChunkSize.x := M1;
  with Ki.WAV do
  begin
    case nChannels of
      1: if nBitsPerSample = 16 then
        begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
          ChunkSize.up := trunc(Ki.yyy[N] + 0.5);
          if N < MaxN then
            ChunkSize.dn := trunc(Ki.yyy[N + 1] + 0.5);
          N := N + 2;
        end
        else
        begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
          for I := 0 to 3 do
            ChunkSize.chrs[I]
              := trunc(Ki.yyy[N + I] + 0.5);
          N := N + 4;
        end;
      2: if nBitsPerSample = 16 then
        begin {2 Двухканальный 16-битный сэмпл}
          ChunkSize.dn := trunc(Ki.yyy[N] + 0.5);
          ChunkSize.up := trunc(Kj.yyy[N] + 0.5);
          N := N + 1;
        end
        else
        begin {4 Двухканальный 8-битный сэмпл}
          ChunkSize.chrs[1] := trunc(Ki.yyy[N] + 0.5);
          ChunkSize.chrs[3] := trunc(Ki.yyy[N + 1] + 0.5);
          ChunkSize.chrs[0] := trunc(Kj.yyy[N] + 0.5);
          ChunkSize.chrs[2] := trunc(Kj.yyy[N + 1] + 0.5);
          N := N + 2;
        end;
    end; {with WAV do begin..}
  end; {четырехбайтовая переменная "ChunkSize" теперь заполнена}
  ChunkSize.x := T1;
  WriteChunkSize(ChunkSize.lint); {помещаем 4 байта данных}
end; {WriteOneDataBlock}
procedure WriteWAVFile(var Ki, Kj: Observation);
var
  MM: Byte;
  I: Integer;
  OK: Boolean;
begin
  {Приготовления для записи файла данных}
  AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }
  ReWrite(OutFile);
  with Ki.WAV do
  begin
    DataSize := nChannels * (nBitsPerSample div 8) * (Ki.Last + 1);
    RIFFSize := DataSize + 36;
    fmtSize := 16;
  end;
  {Записываем ChunkName "RIFF"}
  WriteChunkName('RIFF');
  {Записываем ChunkSize}
  WriteChunkSize(Ki.WAV.RIFFSize);
  {Записываем ChunkName "WAVE"}
  WriteChunkName('WAVE');
  {Записываем tag "fmt_"}
  WriteChunkName('fmt ');
  {Записываем ChunkSize}
  Ki.WAV.fmtSize := 16; {должно быть 16-18}
  WriteChunkSize(Ki.WAV.fmtSize);
  {Записываем  formatTag, nChannels}
  WriteChunkWord(Ki.WAV.formatTag);
  WriteChunkWord(Ki.WAV.nChannels);
  {Записываем  nSamplesPerSec}
  WriteChunkSize(Ki.WAV.nSamplesPerSec);
  {Записываем  nAvgBytesPerSec}
  WriteChunkSize(Ki.WAV.nAvgBytesPerSec);
  {Записываем  nBlockAlign, nBitsPerSample}
  WriteChunkWord(Ki.WAV.nBlockAlign);
  WriteChunkWord(Ki.WAV.nBitsPerSample);
  {Записываем метку блока данных "data"}
  WriteChunkName('data');
  {Записываем DataSize}
  WriteChunkSize(Ki.WAV.DataSize);
  N := 0; {первая запись-позиция}
  while N <= Ki.Last do
    WriteOneDataBlock(Ki, Kj); {помещаем 4 байта и увеличиваем счетчик N}
  {Освобождаем буфер файла}
  CloseFile(OutFile);
end; {WriteWAVFile}
procedure InitSpecs;
begin
end; { InitSpecs }
procedure InitSignals(var Kk: Observation);
var
  J: Integer;
begin
  for J := 0 to MaxN do
    Kk.yyy[J] := 0.0;
  Kk.MinO := 0.0;
  Kk.MaxO := 0.0;
  Kk.Last := MaxN;
end; {InitSignals}
procedure InitAllSignals;
begin
  InitSignals(K0R);
  InitSignals(K0B);
  InitSignals(K1R);
  InitSignals(K1B);
  InitSignals(K2R);
  InitSignals(K2B);
  InitSignals(K3R);
  InitSignals(K3B);
end; {InitAllSignals}
var
  ChunkName: string[4];
procedure ReadChunkName;
var
  I: integer;
  MM: Byte;
begin
  ChunkName[0] := chr(4);
  for I := 1 to 4 do
  begin
    Read(InFile, MM);
    ChunkName[I] := chr(MM);
  end;
end; {ReadChunkName}
procedure ReadChunkSize;
var
  I: integer;
  MM: Byte;
begin
  ChunkSize.x := F0;
  ChunkSize.lint := 0;
  for I := 0 to 3 do
  begin
    Read(InFile, MM);
    ChunkSize.chrs[I] := MM;
  end;
  ChunkSize.x := T1;
end; {ReadChunkSize}
procedure ReadOneDataBlock(var Ki, Kj: Observation);
var
  I: Integer;
begin
  if N <= MaxN then
  begin
    ReadChunkSize; {получаем 4 байта данных}
    ChunkSize.x := M1;
    with Ki.WAV do
      case nChannels of
        1: if nBitsPerSample = 16 then
          begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
            Ki.yyy[N] := 1.0 * ChunkSize.up;
            if N < MaxN then
              Ki.yyy[N + 1] := 1.0 * ChunkSize.dn;
            N := N + 2;
          end
          else
          begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
            for I := 0 to 3 do
              Ki.yyy[N + I] := 1.0 * ChunkSize.chrs[I];
            N := N + 4;
          end;
        2: if nBitsPerSample = 16 then
          begin {2 Двухканальный 16-битный сэмпл}
            Ki.yyy[N] := 1.0 * ChunkSize.dn;
            Kj.yyy[N] := 1.0 * ChunkSize.up;
            N := N + 1;
          end
          else
          begin {4 Двухканальный 8-битный сэмпл}
            Ki.yyy[N] := 1.0 * ChunkSize.chrs[1];
            Ki.yyy[N + 1] := 1.0 * ChunkSize.chrs[3];
            Kj.yyy[N] := 1.0 * ChunkSize.chrs[0];
            Kj.yyy[N + 1] := 1.0 * ChunkSize.chrs[2];
            N := N + 2;
          end;
      end;
    if N <= MaxN then
    begin {LastN    := N;}
      Ki.Last := N;
      if Ki.WAV.nChannels = 2 then
        Kj.Last := N;
    end
    else
    begin {LastN    := MaxN;}
      Ki.Last := MaxN;
      if Ki.WAV.nChannels = 2 then
        Kj.Last := MaxN;
    end;
  end;
end; {ReadOneDataBlock}
procedure ReadWAVFile(var Ki, Kj: Observation);
var
  MM: Byte;
  I: Integer;
  OK: Boolean;
  NoDataYet: Boolean;
  DataYet: Boolean;
  nDataBytes: LongInt;
begin
  if FileExists(StandardInput) then
    with Ki.WAV do
    begin { Вызов диалога открытия файла }
      OK := True; {если не изменится где-нибудь ниже}
      {Приготовления для чтения файла данных}
      AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }
      Reset(InFile);
      {Считываем ChunkName "RIFF"}
      ReadChunkName;
      if ChunkName <> 'RIFF' then
        OK := False;
      {Считываем ChunkSize}
      ReadChunkSize;
      RIFFSize := ChunkSize.lint; {должно быть 18,678}
      {Считываем ChunkName "WAVE"}
      ReadChunkName;
      if ChunkName <> 'WAVE' then
        OK := False;
      {Считываем ChunkName "fmt_"}
      ReadChunkName;
      if ChunkName <> 'fmt ' then
        OK := False;
      {Считываем ChunkSize}
      ReadChunkSize;
      fmtSize := ChunkSize.lint; {должно быть 18}
      {Считываем  formatTag, nChannels}
      ReadChunkSize;
      ChunkSize.x := M1;
      formatTag := ChunkSize.up;
      nChannels := ChunkSize.dn;
      {Считываем  nSamplesPerSec}
      ReadChunkSize;
      nSamplesPerSec := ChunkSize.lint;
      {Считываем  nAvgBytesPerSec}
      ReadChunkSize;
      nAvgBytesPerSec := ChunkSize.lint;
      {Считываем  nBlockAlign}
      ChunkSize.x := F0;
      ChunkSize.lint := 0;
      for I := 0 to 3 do
      begin
        Read(InFile, MM);
        ChunkSize.chrs[I] := MM;
      end;
      ChunkSize.x := M1;
      nBlockAlign := ChunkSize.up;
      {Считываем  nBitsPerSample}
      nBitsPerSample := ChunkSize.dn;
      for I := 17 to fmtSize do
        Read(InFile, MM);
      NoDataYet := True;
      while NoDataYet do
      begin
        {Считываем метку блока данных "data"}
        ReadChunkName;
        {Считываем DataSize}
        ReadChunkSize;
        DataSize := ChunkSize.lint;
        if ChunkName <> 'data' then
        begin
          for I := 1 to DataSize do
            {пропуск данных, не относящихся к набору звуковых данных}
            Read(InFile, MM);
        end
        else
          NoDataYet := False;
      end;
      nDataBytes := DataSize;
      {Наконец, начинаем считывать данные для байтов nDataBytes}
      if nDataBytes > 0 then
        DataYet := True;
      N := 0; {чтение с первой позиции}
      while DataYet do
      begin
        ReadOneDataBlock(Ki, Kj); {получаем 4 байта}
        nDataBytes := nDataBytes - 4;
        if nDataBytes <= 4 then
          DataYet := False;
      end;
      ScaleData(Ki);
      if Ki.WAV.nChannels = 2 then
      begin
        Kj.WAV := Ki.WAV;
        ScaleData(Kj);
      end;
      {Освобождаем буфер файла}
      CloseFile(InFile);
    end
  else
  begin
    InitSpecs; {файл не существует}
    InitSignals(Ki); {обнуляем массив "Ki"}
    InitSignals(Kj); {обнуляем массив "Kj"}
  end;
end; { ReadWAVFile }
{================= Операции с набором данных ====================}
const
  MaxNumberOfDataBaseItems = 360;
type
  SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;
var
  DataBaseFile: file of Observation;
  LastDataBaseItem: LongInt; {Номер текущего элемента набора данных}
  ItemNameS: array[SignalDirectoryIndex] of string[40];
procedure GetDatabaseItem(Kk: Observation; N: LongInt);
begin
  if N <= LastDataBaseItem then
  begin
    Seek(DataBaseFile, N);
    Read(DataBaseFile, Kk);
  end
  else
    InitSignals(Kk);
end; {GetDatabaseItem}
procedure PutDatabaseItem(Kk: Observation; N: LongInt);
begin
  if N < MaxNumberOfDataBaseItems then
    if N <= LastDataBaseItem then
    begin
      Seek(DataBaseFile, N);
      Write(DataBaseFile, Kk);
      LastDataBaseItem := LastDataBaseItem + 1;
    end
    else
      while LastDataBaseItem <= N do
      begin
        Seek(DataBaseFile, LastDataBaseItem);
        Write(DataBaseFile, Kk);
        LastDataBaseItem := LastDataBaseItem + 1;
      end
  else
    ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}
end; {PutDatabaseItem}
procedure InitDataBase;
begin
  LastDataBaseItem := 0;
  if FileExists(StandardDataBase) then
  begin
    Assign(DataBaseFile, StandardDataBase);
    Reset(DataBaseFile);
    while not EOF(DataBaseFile) do
    begin
      GetDataBaseItem(K0R, LastDataBaseItem);
      ItemNameS[LastDataBaseItem] := K0R.Name;
      LastDataBaseItem := LastDataBaseItem + 1;
    end;
    if EOF(DataBaseFile) then
      if LastDataBaseItem > 0 then
        LastDataBaseItem := LastDataBaseItem - 1;
  end;
end; {InitDataBase}
function FindDataBaseName(Nstg: string): LongInt;
var
  ThisOne: LongInt;
begin
  ThisOne := 0;
  FindDataBaseName := -1;
  while ThisOne < LastDataBaseItem do
  begin
    if Nstg = ItemNameS[ThisOne] then
    begin
      FindDataBaseName := ThisOne;
      Exit;
    end;
    ThisOne := ThisOne + 1;
  end;
end; {FindDataBaseName}
{======================= Инициализация модуля ========================}
procedure InitLinearSystem;
begin
  BaseFileName := '\PROGRA~1\SIGNAL~1\';
  StandardOutput := BaseFileName + 'K0.wav';
  StandardInput := BaseFileName + 'K0.wav';
  StandardDataBase := BaseFileName + 'Radar.sdb';
  InitAllSignals;
  InitDataBase;
  ReadWAVFile(K0R, K0B);
  ScaleAllData;
end; {InitLinearSystem}
begin {инициализируемый модулем код}
  InitLinearSystem;
end. {Unit LinearSystem}

Разукрасьте Ваше приложение (Skins).

SkinForm - это компонент, который поможет Вам создать "не-квадратное" окно и вто же время применить к нему так называемую технологию "skin", наподобие таких популярных программ как WinAMP, WPlay ..., зачем тратить часы на программирование, когда это можно сделать за пару минут! Скачать сам компонент можно с http://www.qwerks.com/download.asp?ProductID=2447. WYSIWYG скин билдер, который входит в состав архива, предназначен для создания информационного файла, описывающего структуру нашей формы. Всё, что надо сделать - это создать несколько картинок, и нарисовать кнопки, текстовые поля и т.д.. Есть возможность постоянно смотреть превью!

Теперь посмотрим, какие нам предоставлены возможности:

Теперь наши действия:

Посмотрим на script файл, созданный SkinBuilder-ом:

[VERSION]
Ver=210 // Версия скин-файла 
[BITMAPINFO] 
MaskBitmap=PlayerMask.bmp 
// Bitmap файл маски поверхности формы 
MouseUpBitmap=PlayerMain.jpg 
// Bitmap файл, если кнопка мыши была отпущена 
MouseDownBitmap=PlayerSel.jpg 
// Bitmap файл, если кнопка мыши была нажата 
MouseOnBitmap=PlayerSel.jpg 
// Bitmap файла, если на объекте находится курсор мыши 
NumbersBitmap= 
// Bitmap файл для графических цифр (не обязательно)
TextBitmap= 
// Bitmap файл для графического текста (не обязательно) 
[HOTAREAINFO] 
Count=19 // Общее количество кнопок 
// Описание каждой кнопки 
// number=ID, top, left, width, height, hint [, button state, group name] 
// Значения в [ ] не обязательны 
1=BUTTON_PLAY, 54, 165, 34, 35, Play/Pause 
2=BUTTON_STOP, 129, 165, 19, 35, Stop 
3=BUTTON_NEXT, 90, 165, 18, 17, Next 
4=BUTTON_PREV, 109, 165, 18, 17, Previous 
... 
[DISPLAYINFO] 
Charset=1 // Charset текстовой области 
Count=3 // количество тектовых полей 
// Описание каждой текстовой области 
// number=ID, font name, bold, italic, size, color, top, left, style, default text, hint, width, height 
1=TEXT_LEN, Arial, TRUE, FALSE, 9, $00366835, 116, 137, Normal, [00:00], Length, 51, 18 
2=TEXT_POS, Arial, TRUE, FALSE, 12, $00366835, 55, 133, Normal, 00:00, Position, 52, 23 
3=TEXT_SONG, MS Sans Serif, FALSE, FALSE, 7, $00366835, 56, 112, Normal, Song name, Song name, 111, 21 
[TRACKBARINFO] 
Count=2 // Количество track-баров 
// Описание каждого трак-бара 
// number=ID, trackbar bitmap file, trackbar bitmap file, top, left, length, style, position, hint 
1=TRACKBAR_VOLUME, TrackBar.BMP, TrackBar.BMP, 79, 205, 88, H, 65, Volume 
2=TRACKBAR_POS, TrackBar.BMP, TrackBar.BMP, 79, 217, 88, H, 0, Time

Ну вот Ваше приложение и разукрасилось и, как видите, безо всякого программирования.

Теперь можно добавить код, чтобы перехватывать события на кнопках - MouseUp, Down, Over ...

Далее следует пример кода:

...
procedure TForm1.FormCreate(Sender: TObject);
begin
  //Загружаем скин файл
  SkinForm1.LoadDefaultSkin;
  SkinForm1.SetDisplayText('VOLUME', IntToStr(SkinForm1.GetTrackBarPos('TRACKBAR_VOLUME')));
  SkinForm1.SetDisplayText('TIME', IntToStr(SkinForm1.GetTrackBarPos('TRACKBAR_POS')));
  SkinForm1.SetTrackBarMinMax('TRACKBAR_VOLUME', 20, 80);
end;
procedure TForm1.SkinForm1MouseUpNotify(ID: string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  pos: TPoint;
begin
  if (Button = mbLeft) then
  begin
    if ID = 'BUTTON_EXIT' then
      Close;
    if ID = 'BUTTON_MINIMIZE' then
      Form1.Perform(WM_SYSCOMMAND, SC_MINIMIZE, 0);
    if ID = 'BUTTON_MENU' then
    begin
      pos := ClientToScreen(Point(X, Y));
      PopupMenu1.Popup(pos.x, pos.y);
    end;
  end;
  if (Button = mbRight) then
  begin
    pos := ClientToScreen(Point(X, Y));
    PopupMenu1.Popup(pos.x, pos.y);
  end;
...

Убывающий индекс.

Я нашел простой способ получения убывающего индекса. В Delphi это получается очень легко и красиво:

Table1.AddIndex('NewIndex', 'CustNo;CustName', [ixDescending]);

Как преобразовать числовое значение в римскую интерпретацию.

Передайте данной функции любую десятичную величину (1...3999), и она возвратит строку, содержащую точное значение в римской транскрипции.

function DecToRoman(Decimal: LongInt): string;
const
  Romans: array[1..13] of string =
  ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
  Arabics: array[1..13] of Integer =
  (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
var
  i: Integer;
  scratch: string;
begin
  scratch := '';
  for i := 13 downto 1 do
    while (Decimal >= Arabics[i]) do
    begin
      Decimal := Decimal - Arabics[i];
      scratch := scratch + Romans[i];
    end;
  Result := scratch;
end;

Определить SMTP сервер по умолчанию.

{ 
  Here is some code I successfully used te determine 
  the DEFAULT mailaccount, which is used in 
  Outlook Express, to send outgoing mail via SMTP. 
} 
procedure TForm1.ReadRegistryDefaults; 
var 
  Registry: TRegistry; 
  AccountStr: string; 
begin 
  Registry := TRegistry.Create; 
  try 
    Registry.RootKey := hkey_CURRENT_USER; 
    if Registry.OpenKey('software\microsoft\internet account manager', False) then  {} 
    begin 
      AccountStr := Registry.ReadString('default mail account'); 
      Registry.CloseKey; 
      if (AccountStr <> '') then 
        if Registry.OpenKey('software\microsoft\internet account manager\accounts\' + 
          AccountStr, False) then  {} 
        begin 
          Edit_Server.Text  := Registry.ReadString('SMTP Server'); 
          Edit_Account.Text := Registry.ReadString('SMTP Email Address'); 
          Registry.CloseKey; 
        end; 
    end; 
  finally 
    Registry.Free; 
  end; 
end;

Как узнать язык Windows по умолчанию.

GetSystemDefaultLangID
GetSystemDefaultLCID
GetLocaleInfo 

Демонстрация DefineProperties.

Автор: Mike Scott(Mobius Ltd.).

Удачи!

unit PropDemo;
{ Демонстрация DefineProperties.
Mike Scott, CIS 100140,2420. }
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;
type
  TDemoProps = class(TComponent)
  private
    { Private declarations }
    FStringThing: string;
    FThing: record
      i, j, k: integer;
      x, y: real;
      ch: char;
    end;
    procedure ReadStringThing(Reader: TReader);
    procedure WriteStringThing(Writer: TWriter);
    procedure ReadThing(Stream: TStream);
    procedure WriteThing(Stream: TStream);
  protected
    { Protected declarations }
    procedure DefineProperties(Filer: TFiler); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
  end;
procedure Register;
implementation
constructor TDemoProps.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { создайте любые данные, чтобы было что передать в поток}
  FStringThing := 'Всем привет!';
  with FThing do
  begin
    i := 1;
    j := 2;
    k := 3;
    x := PI;
    y := 180 / PI;
    ch := '?';
  end;
end;
procedure TDemoProps.ReadStringThing(Reader: TReader);
begin
  FStringThing := Reader.ReadString;
end;
procedure TDemoProps.WriteStringThing(Writer: TWriter);
begin
  Writer.WriteString(FStringThing);
end;
procedure TDemoProps.ReadThing(Stream: TStream);
begin
  Stream.ReadBuffer(FThing, sizeof(FThing));
end;
procedure TDemoProps.WriteThing(Stream: TStream);
begin
  Stream.WriteBuffer(FThing, sizeof(FThing));
end;
procedure TDemoProps.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing,
    FStringThing <> '');
  Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true);
end;
procedure Register;
begin
  RegisterComponents('Samples', [TDemoProps]);
end;
end.

Код определения свойств.