How to write in-memory database applications in Lazarus/FPC/ru

│ English (en) │ français (fr) │ 日本語 (ja) │ русский (ru) │

Databases portal

References: General info Libraries Field types Controls FAQ SQL how-to Working With TSQLQuery In-memory database applications Tutorials/practical articles: Overview 0 - Database set-up 1 - Getting started 2 - Editing 3 - Queries 4 - Data modules SQLdb Programming Reference Databases Advantage - MySQL - MSSQL - Postgres - Interbase - Firebird - Oracle - ODBC - Paradox - SQLite - dBASE - MS Access - Zeos

Введение

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

Некоторые преимущества:

• Быстрое выполнение. Поскольку вся обработка выполняется в памяти, данные не сохраняются на жестком диске до тех пор, пока это не будет задано явно. Память, безусловно, быстрее, чем жесткий диск.
• Нет необходимости во внешних библиотеках (нет файлов .so или .dll), нет необходимости в установке сервера.
• Код является мультиплатформенным и может быть скомпилирован в любой ОС.
• Поскольку все программирование выполняется в Lazarus/FPC, такие приложения проще в обслуживании. Вместо того, чтобы постоянно переключаться с внутреннего программирования на внешнее, используя MemDatasets, вы можете сосредоточиться на своем коде Pascal.

  Примечание: позже в этой статье будет представлен BufDataset. TBufDataset часто является лучшим выбором, чем TMemDataset

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

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

Модуль memds предоставляет TMemDataset, так что вам нужно будет добавить его в раздел uses вашего проекта.

Сохранение MemDataset в постоянные файлы

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

Я также использую глобальную переменную vSuppressEvents типа boolean для подавления событий Dataset, используемых для обеспечения ссылочной целостности, во время восстановления данных.

Вот, что у вас должно получиться:

type
  TSaveTables=array[1..15] of TMemDataset;    
var
  //Глобальная переменная, которая хранит таблицы для сохранения/восстановления сеанса работы
  vSaveTables:TSaveTables;                  
  //Переменная-флаг подавления событий датасета. Используется при загрузке данных из файлов.
  vSuppressEvents:Boolean;

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

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

const
  //Константа cSaveRestore определяет способ сохранения и восстановления MemDataset в постоянные файлы.
  cSaveRestore=0; //0=собственный формат MemDataset, 1=сохранение и восстановление из CSV

Теперь вы можете сохранить MemDataset'ы в событии OnFormClose и загрузить их в событие OnFormCreate. Заполнить элементы массива экземплярами MemDataset можно также в событии OnFormCreate.

procedure TMainForm.FormCreate(Sender: TObject);
begin
  //Список таблиц, которые будут сохранены/восстановлены для сеанса работы
  vSaveTables[1]:=Products;
  vSaveTables[2]:=Boms;
  vSaveTables[3]:=Stocks;
  vSaveTables[4]:=Orders;
  vSaveTables[5]:=BomCalculationProducts;
  vSaveTables[6]:=BomCalculationComponents;
  vSaveTables[7]:=BomCalculationFooter;
  vSaveTables[8]:=BomCalculationProductsMultiple;
  vSaveTables[9]:=BomCalculationComponentsMultiple;
  vSaveTables[10]:=BomCalculationFooterMultiple;
  vSaveTables[11]:=ImportVariants;
  vSaveTables[12]:=ImportToTables;
  vSaveTables[13]:=ImportToFields;
  vSaveTables[14]:=ImportFromTables;
  vSaveTables[15]:=ImportFromFields;
  //Восстанавливаем сеанс работы
  RestoreSession;
  GetAutoincrementPrimaryFields;
end;

procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
 //Сохраняем наборы данных в файлы (чтобы сохранить текущий сеанс)
 SaveSession;
end;

procedure RestoreSession;
var
  I:Integer;
begin
  try
    MemoMessages.Append(TimeToStr(Now())+' Начало восстановления ранее сохраненного сеанса.');
    vSuppressEvents:=True; //Подавляем события, используемые для обеспечения ссылочной целостности
    //Отключаем элементы управления и обновляем все наборы данных
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].DisableControls;
      vSaveTables[I].Refresh; //Важный момент, если набор данных был отфильтрован
    end;
    //Загружаем memdataset'ы из файлов (для восстановления предыдущего сеанса)
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].First;
      MemoMessages.Append(TimeToStr(Now())+' Начинаем восстановление таблицы: '+vSaveTables[I].Name);
      try
        //Если данные загружаются из CSV-файла, то сначала необходимо удалить таблицу.
        if cSaveRestore=1 then begin
          MemoMessages.Append(TimeToStr(Now())+' Начинаем удаление всех записей в таблице: '+vSaveTables[I].Name);
          //Этот способ удаления всех записей невероятно медленный.
          {while not vSaveTables[I].EOF do begin
            vSaveTables[I].Delete;
          end;}
          //Этот метод для удаления всех записей намного быстрее
          EmptyMemDataSet(vSaveTables[I]);
          MemoMessages.Append(TimeToStr(Now())+' Все записи из таблицы: '+vSaveTables[I].Name+' удалены.');
        end;
      except
        on E:Exception do begin
          MemoMessages.Append(TimeToStr(Now())+' Ошибка при удалении записей из таблицы: '+vSaveTables[I].Name +'. '+E.Message);
        end;
      end;
      try
        try
          MemoMessages.Append(TimeToStr(Now())+' Восстановление таблицы: '+vSaveTables[I].Name);
          //Проверяем константу для выбора способа сохранения/восстановления данных и загрузки сохраненного сеанса
          case cSaveRestore of
            0:vSaveTables[I].LoadFromFile(vSaveTables[I].Name);
            1:LoadFromCsv(vSaveTables[I]);
          end;
        except
          on E:Exception do begin
            MemoMessages.Append(TimeToStr(Now())+' Ошибка при восстановлении таблицы: '+vSaveTables[I].Name +'. '+E.Message);
          end;
        end;
      finally
        vSaveTables[I].Active:=True;//Требуется из-за метода LoadFromFile....
      end;
      MemoMessages.Append(TimeToStr(Now())+' Таблица: '+vSaveTables[I].Name+' восстановлена.');
    end;
  finally
    vSuppressEvents:=False;
    //Обновляем все наборы данных и включаем элементы управления
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].Refresh; //Необходимо для таблиц, которые фильтруются.
      vSaveTables[I].EnableControls;
    end;
     MemoMessages.Append(TimeToStr(Now())+' Все таблицы восстановлены из сохраненных файлов.');
  end;
end;

procedure SaveSession;
var
  I:Integer;
begin
  try
    MemoMessages.Append(TimeToStr(Now())+' Начало сохранения сеанса в постоянные файлы.');
    vSuppressEvents:=True;
    //Отключаем элементы управления и обновляем все наборы данных
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].DisableControls;
      vSaveTables[I].Refresh; //Важный момент, если набор данных был отфильтрован
    end;
    //Сохраняем сеанс работы в файл
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].First;
      MemoMessages.Append(TimeToStr(Now())+' Сохранение таблицы: '+vSaveTables[I].Name);
      try
        //Проверяем константу для выбора способа сохранения/восстановления данных и загрузки сохраненного сеанса
        case cSaveRestore of
          0:vSaveTables[I].SaveToFile(vSaveTables[I].Name);
          1:SaveToCsv(vSaveTables[I]);
        end;
      except
        on E:Exception do begin
          MemoMessages.Append(TimeToStr(Now())+' Ошибка при сохранении таблицы: '+vSaveTables[I].Name +'. '+E.Message);
        end;
      end;
      MemoMessages.Append(TimeToStr(Now())+' Таблица: '+vSaveTables[I].Name+' сохранена.');
    end;
  finally
    vSuppressEvents:=False;
    //Обновляем все наборы данных и включаем элементы управления
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].Refresh; //Необходимо для таблиц, которые фильтруются
      vSaveTables[I].EnableControls;
    end;
     MemoMessages.Append(TimeToStr(Now())+' Все таблицы сохранены в файлы.');
  end;
end;

procedure EmptyMemDataSet(DataSet:TMemDataSet);
var
  vTemporaryMemDataSet:TMemDataSet;
  vFieldDef:TFieldDef;
  I:Integer;
begin
  try
    //Создаем временный MemDataSet
    vTemporaryMemDataSet:=TMemDataSet.Create(nil);
    //Сохраняем FieldDefs во временном MemDataSet
    for I:=0 to DataSet.FieldDefs.Count-1 do begin
      vFieldDef:=vTemporaryMemDataSet.FieldDefs.AddFieldDef;
      with DataSet.FieldDefs[I] do begin
        vFieldDef.Name:=Name;
        vFieldDef.DataType:=DataType;
        vFieldDef.Size:=Size;
        vFieldDef.Required:=Required;
      end;
    end;
    //Очищаем существующие fielddefs
    DataSet.Clear;
    //Восстанавливаем fielddefs
    DataSet.FieldDefs:=vTemporaryMemDataSet.FieldDefs;
    DataSet.Active:=True;
  finally
  vTemporaryMemDataSet.Clear;
  vTemporaryMemDataSet.Free;
  end;
end;

procedure LoadFromCsv(DataSet:TDataSet);
var
  vFieldCount:Integer;
  I:Integer;
begin
  try
    //Назначаем SdfDataSetTemporary
    with SdfDataSetTemporary do begin
      Active:=False;
      ClearFields;
      FileName:=DataSet.Name+'.txt';
      FirstLineAsSchema:=True;
      Active:=True;
      //Определяем количество полей
      vFieldCount:=FieldDefs.Count;
    end;
    //Выполняем итерацию по SdfDataSetTeditional и вставляем записи в MemDataSet.
    SdfDataSetTemporary.First;
    while not SdfDataSetTemporary.EOF do begin
      DataSet.Append;
      //Итерация по FieldDefs
      for I:=0 to vFieldCount-1 do begin
        try
          DataSet.Fields[I].Value:=SdfDataSetTemporary.Fields[I].Value;
        except
          on E:Exception do begin
            MemoMessages.Append(TimeToStr(Now())+' Ошибка при установке значения для поля: '
             +DataSet.Name+'.'+DataSet.Fields[I].Name +'. '+E.Message);
          end;
        end;
      end;
      try
        DataSet.Post;
      except
        on E:Exception do begin
          MemoMessages.Append(TimeToStr(Now())+' Ошибка при сохранении записи в таблицу: '
           +DataSet.Name+'.'+E.Message);
        end;
      end;
      SdfDataSetTemporary.Next;
    end;
  finally
    SdfDataSetTemporary.Active:=False;
    SdfDataSetTemporary.ClearFields;
  end;
end;

procedure SaveToCsv(DataSet:TDataSet);
var
  myFileName:string;
  myTextFile: TextFile;
  i: integer;
  s: string;
begin
  myFileName:=DataSet.Name+'.txt';
  //создаем новый файл
  AssignFile(myTextFile, myFileName);
  Rewrite(myTextFile);
  s := ''; //инициализируем пустую строку
  try
    //записываем имена полей (как заголовки столбцов)
    for i := 0 to DataSet.Fields.Count - 1 do
      begin
        s := s + Format('%s,', [DataSet.Fields[i].FieldName]);
      end;
    Writeln(myTextFile, s);
    DataSet.First;
    //записываем значения полей
    while not DataSet.Eof do
      begin
        s := '';
        for i := 0 to DataSet.FieldCount - 1 do
          begin
            //Числовые поля без кавычек, строковые поля с кавычками
            if ((DataSet.FieldDefs[i].DataType=ftInteger)
             or (DataSet.FieldDefs[i].DataType=ftFloat)) then
              s := s + Format('%s,', [DataSet.Fields[i].AsString])
            else
              s := s + Format('"%s",', [DataSet.Fields[i].AsString]);
          end;
        Writeln(myTextfile, s);
        DataSet.Next;
      end;
  finally
    CloseFile(myTextFile);
  end;
end;

Autoincrement Primary Keys

Autoincrement field type is not supported by MemDataset. Nevertheless, you can imitate it by using Integer field type and providing a calculator for autoincrement fields. We need global variables or public properties for storing current autoincrement field value. I prefer global variables, declared in Interface part.

var
  //Global variables used for calculation of autoincrement primary key fields of MemDatasets
  vCurrentId:Integer=0;
  vProductsId:Integer=0;
  vBomsId:Integer=0;
  vBomCalculationProductsId:Integer=0;
  vBomCalculationComponentsId:Integer=0;
  vBomCalculationFooterId:Integer=0;
  vBomCalculationProductsMultipleId:Integer=0;
  vBomCalculationComponentsMultipleId:Integer=0;
  vBomCalculationFooterMultipleId:Integer=0;
  vStocksId:Integer=0;
  vOrdersId:Integer=0;
  vImportVariantsId:Integer=0;
  vImportToTablesId:Integer=0;
  vImportToFieldsId:Integer=0;
  vImportFromTablesId:Integer=0;
  vImportFromFieldsId:Integer=0;

Then we have a procedure for autoincrement field values calculation:

procedure GetAutoincrementPrimaryFields;
var
  I:Integer;
  vId:^Integer;
begin
  try
    MemoMessages.Lines.Append(TimeToStr(Now())+' Getting information about autoincrement fields');
    vSuppressEvents:=True;
    //Disable controls and refresh all datasets
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].DisableControls;
      vSaveTables[I].Refresh; //Important if dataset was filtered
    end;
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      with vSaveTables[I] do begin
        //Use appropriate global variable
        case StringToCaseSelect(Name,
          ['Products','Boms','Stocks','Orders',
            'BomCalculationProducts','BomCalculationComponents','BomCalculationFooter',
            'BomCalculationProductsMultiple','BomCalculationComponentsMultiple','BomCalculationFooterMultiple',
            'ImportVariants','ImportToTables','ImportToFields','ImportFromTables','ImportFromFields']) of
          0:vId:=@vProductsId;
          1:vId:=@vBomsId;
          2:vId:=@vStocksId;
          3:vId:=@vOrdersId;
          4:vId:=@vBomCalculationProductsId;
          5:vId:=@vBomCalculationComponentsId;
          6:vId:=@vBomCalculationFooterId;
          7:vId:=@vBomCalculationProductsMultipleId;
          8:vId:=@vBomCalculationComponentsMultipleId;
          9:vId:=@vBomCalculationFooterMultipleId;
          10:vId:=@vImportVariantsId;
          11:vId:=@vImportToTablesId;
          12:vId:=@vImportToFieldsId;
          13:vId:=@vImportFromTablesId;
          14:vId:=@vImportFromFieldsId;
        end;
        try
          //Find last value of Id and save it to global variable
          Last;
          vCurrentId:=FieldByName(Name+'Id').AsInteger;
          if (vCurrentId>vId^) then vId^:=vCurrentId;
        finally
          //Remove reference;
          vId:=nil;
        end;
      end;
    end;
  finally
    vSuppressEvents:=False;
    //Refresh all datasets  and enable controls
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].Refresh;
      vSaveTables[I].EnableControls;
    end;
     MemoMessages.Lines.Append(TimeToStr(Now())+' Autoincrement fields - done.');
  end;
end;

function StringToCaseSelect(Selector:string;CaseList:array of string):Integer;
var 
  cnt: integer;
begin
  Result:=-1;
  for cnt:=0 to Length(CaseList)-1 do
  begin
    if CompareText(Selector, CaseList[cnt]) = 0 then
    begin
      Result:=cnt;
      Break;
    end;
  end;
end;

The GetAutoincrementPrimaryFields procedure is called every time after you restore (load) data from persistent files, in order to load last autoincrement values into global variables (or properties, as you prefer). Autoincrementing is done in OnNewRecord event of every MemDataset. For example, for MemDataset Orders:

procedure TMainForm.OrdersNewRecord(DataSet: TDataSet);
begin
  if vSuppressEvents=True then Exit;
  //Set new autoincrement value
  vOrdersId:=vOrdersId+1;
  DataSet.FieldByName('OrdersId').AsInteger:=vOrdersId;
end;

As already explained, I use vSuppressEvents global variable as flag for the case of restoring data from persistent files.

Enforcing Referential Integrity

There is no enforced referential integrity implemented in MemDataset component, so you have to do it on your own.

Let's assume we have two tables: MasterTable and DetailTable.

There are various places where referential integrity code needs to be used:

• Insert/Update code is located in the BeforePost event of the DetailTable: before a new/updated detail record is posted/saved, it needs to be checked for meeting referential integrity requirements
• Delete code is located in the BeforeDelete event of the MasterTable: before a master record is deleted, it needs to make sure any child records meet referential integrity requirements

procedure TMainForm.MasterTableBeforeDelete(DataSet: TDataSet);
begin
  if vSuppressEvents=True then Exit;
  try
    DetailTable.DisableControls;
    // Enforce referential delete ("cascade delete") for table "MasterTable"
    while not DetailTable.EOF do begin
      DetailTable.Delete;
    end;
    DetailTable.Refresh;
  finally
    DetailTable.EnableControls;
  end;
end;

procedure TMainForm.DetailTableBeforePost(DataSet: TDataSet);
begin
  if vSuppressEvents=True then Exit;
  // Enforce referential insert/update for table "DetailTable" with
  // foreign key "MasterTableID" linking to
  // the MasterTable ID primary key field
  DataSet.FieldByName('MasterTableId').AsInteger:=
    MasterTable.FieldByName('ID').AsInteger;
end;

After you provided referential Insert/Update/Delete, all you must do is provide code for master/detail filtering of data. You do it in the AfterScroll event of the MasterTable and in the OnFilter event of the DetailTable.

Don't forget to set the Filtered property of DetailTable to True.

procedure TMainForm.MasterTableAfterScroll(DataSet: TDataSet);
begin
  if vSuppressEvents=True then Exit;
  DetailTable.Refresh;
end;

procedure TMainForm.DetailTableFilterRecord(DataSet: TDataSet;
  var Accept: Boolean);
begin
  if vSuppressEvents=True then Exit;
  // Show only child fields whose foreign key points to current
  // master table record
  Accept:=DataSet.FieldByName('MasterTableId').AsInteger=
    MasterTable.FieldByName('ID').AsInteger;
end;

Known problems

There are several limitations when using MemDatasets.

• Locate method does not work
• Filtering by using Filter and Filtered property does not work. You must use hardcoding in the OnFilter event.
• Looping deletion of records seems to be incredibly slow. Therefore I use my EmptyMemDataset procedure instead of while not EOF do Delete;
• In FPC 2.6.x and earlier, CopyFromDataSet method copies data only from the current cursor position to the end of the source dataset. So, you have to write MemDataset1.First; before MemDataSet2.CopyFromDataSet(MemDataset1);. Fixed in FPC trunk revision 26233.
  • Note that older versions of FPC has no CopyFromDataset in Bufdataset, at the time an advantage for MemDs.
  • See bug report http://bugs.freepascal.org/view.php?id=25426.

TBufDataSet

As previously mentioned, MemDataSet lacks custom filters, autoincrement data type and the Locate method, so it is better to use TBufDataSet instead. TBufDataset is provided by the BufDataset unit.

Since there is no component for design-time editing of TBufDataSet (but you can set up field definitions at design time), you could create a custom wrapper component or use it through code, in the same way as ClientDataSet in Delphi. Look at the Delphi documentation relating to client datasets for details.

You can use the same methods for enforcing referential integrity and primary autoincrement fields as explained for MemDataSet.

There are only small differences between MemDataSet and BufDataset:

MemDataSet	BufDataset
DataSet.ClearFields	DataSet.Fields.Clear
DataSet.CreateTable	DataSet.CreateDataSet

Sorting DBGrid on TitleClick event for TBufDataSet

If you wish to enable consecutive ascending and descending sorting of a DBGrid showing some data from TBufDataSet, you could use the following method:

Uses
  BufDataset, typinfo;

function SortBufDataSet(DataSet: TBufDataSet;const FieldName: String): Boolean;
var
  i: Integer;
  IndexDefs: TIndexDefs;
  IndexName: String;
  IndexOptions: TIndexOptions;
  Field: TField;
begin
  Result := False;
  Field := DataSet.Fields.FindField(FieldName);
  //If invalid field name, exit.
  if Field = nil then Exit;
  //if invalid field type, exit.
  if {(Field is TObjectField) or} (Field is TBlobField) or
    {(Field is TAggregateField) or} (Field is TVariantField)
     or (Field is TBinaryField) then Exit;
  //Get IndexDefs and IndexName using RTTI
  if IsPublishedProp(DataSet, 'IndexDefs') then
    IndexDefs := GetObjectProp(DataSet, 'IndexDefs') as TIndexDefs
  else
    Exit;
  if IsPublishedProp(DataSet, 'IndexName') then
    IndexName := GetStrProp(DataSet, 'IndexName')
  else
    Exit;
  //Ensure IndexDefs is up-to-date
  IndexDefs.Updated:=false; {<<<<---This line is critical as IndexDefs.Update will do nothing on the next sort if it's already true}
  IndexDefs.Update;
  //If an ascending index is already in use,
  //switch to a descending index
  if IndexName = FieldName + '__IdxA'
  then
    begin
      IndexName := FieldName + '__IdxD';
      IndexOptions := [ixDescending];
    end
  else
    begin
      IndexName := FieldName + '__IdxA';
      IndexOptions := [];
    end;
  //Look for existing index
  for i := 0 to Pred(IndexDefs.Count) do
  begin
    if IndexDefs[i].Name = IndexName then
      begin
        Result := True;
        Break
      end;  //if
  end; // for
  //If existing index not found, create one
  if not Result then
      begin
        if IndexName=FieldName + '__IdxD' then
          DataSet.AddIndex(IndexName, FieldName, IndexOptions, FieldName)
        else
          DataSet.AddIndex(IndexName, FieldName, IndexOptions);
        Result := True;
      end; // if not
  //Set the index
  SetStrProp(DataSet, 'IndexName', IndexName);
end;

So, you can call this function from a DBGrid in this way:

procedure TFormMain.DBGridProductsTitleClick(Column: TColumn);
begin
  SortBufDataSet(Products, Column.FieldName);
end;

Sorting multiple columns in grid

I have written TDBGridHelper for sorting grid by multiple columns while holding shift key. Note MaxIndexesCount must be set quite large for TBufDataSet because there can be quite large combinations of possible sorting options. But I think people would not use more than 10 so setting it 100 should be teoretically Ok.

  { TDBGridHelper }

  TDBGridHelper = class helper for TDBGrid
  public const
    cMaxColCOunt = 3;
  private
    procedure Interbal_MakeNames(Fields: TStrings; out FieldsList, DescFields: String);
    procedure Internal_SetColumnsIcons(Fields: TStrings; AscIdx, DescIdx: Integer);
    function Internal_IndexNameExists(IndexDefs: TIndexDefs; IndexName: String): Boolean;
  public
    procedure Sort(const FieldName: String; AscIdx: Integer = -1; DescIdx: Integer = -1);
    procedure ClearSort;
  end;  

{ TDBGridHelper }

procedure TDBGridHelper.Interbal_MakeNames(Fields: TStrings; out FieldsList, DescFields: String);
var
  FldList: TStringList;
  DscList: TStringList;
  FldDesc, FldName: String;
  i: Integer;
begin
  if Fields.Count = 0 then
  begin
    FieldsList := '';
    DescFields := '';
    Exit;
  end;

  FldList := TStringList.Create;
  DscList := TStringList.Create;
  try
    FldList.Delimiter := ';';
    DscList.Delimiter := ';';

    for i := 0 to Fields.Count - 1 do
    begin
      Fields.GetNameValue(i, FldName, FldDesc);
      FldList.Add(FldName);

      if FldDesc = 'D' then
        DscList.Add(FldName);
    end;

    FieldsList := FldList.DelimitedText;
    DescFields := DscList.DelimitedText;
  finally
    FldList.Free;
    DscList.Free;
  end;
end;

procedure TDBGridHelper.Internal_SetColumnsIcons(Fields: TStrings; AscIdx, DescIdx: Integer);
var
  i: Integer;
  FldDesc: String;
begin
  for i := 0 to Self.Columns.Count - 1 do
  begin
    FldDesc := Fields.Values[Self.Columns[i].Field.FieldName];

    if FldDesc = 'A' then
      Self.Columns[i].Title.ImageIndex := AscIdx
    else
    if FldDesc = 'D' then
      Self.Columns[i].Title.ImageIndex := DescIdx
    else
      Self.Columns[i].Title.ImageIndex := -1
  end;
end;

function TDBGridHelper.Internal_IndexNameExists(IndexDefs: TIndexDefs; IndexName: String): Boolean;
var
  i: Integer;
begin
  for i := 0 to IndexDefs.Count - 1 do
  begin
    if IndexDefs[i].Name = IndexName then
      Exit(True)
  end;

  Result := False
end;

procedure TDBGridHelper.Sort(const FieldName: String; AscIdx: Integer;
  DescIdx: Integer);
var
  Field: TField;
  DataSet: TBufDataset;
  IndexDefs: TIndexDefs;
  IndexName, Dir, DescFields, FieldsList: String;
  Fields: TStringList;
begin
  if not Assigned(DataSource.DataSet) or
     not DataSource.DataSet.Active or
     not (DataSource.DataSet is TBufDataset) then
    Exit;
  DataSet := DataSource.DataSet as TBufDataset;

  Field := DataSet.FieldByName(FieldName);
  if (Field is TBlobField) or (Field is TVariantField) or (Field is TBinaryField) then
    Exit;

  IndexDefs := DataSet.IndexDefs;
  IndexName := DataSet.IndexName;

  if not IndexDefs.Updated then
    IndexDefs.Update;

  Fields := TStringList.Create;
  try
    Fields.DelimitedText := IndexName;
    Dir := Fields.Values[FieldName];

    if Dir = 'A' then
      Dir := 'D'
    else
    if Dir = 'D' then
      Dir := 'A'
    else
      Dir := 'A';

    //If shift is presed then add field to field list
    if ssShift in GetKeyShiftState then
    begin
      Fields.Values[FieldName] := Dir;
      //We do not add to sor any more field if total field count exids cMaxColCOunt
      if Fields.Count > cMaxColCOunt then
        Exit;
    end
    else
    begin
      Fields.Clear;
      Fields.Values[FieldName] := Dir;
    end;

    IndexName := Fields.DelimitedText;
    if not Internal_IndexNameExists(IndexDefs, IndexName) then
    begin
      Interbal_MakeNames(Fields, FieldsList, DescFields);
      TBufDataset(DataSet).AddIndex(IndexName, FieldsList, [], DescFields, '');
    end;

    DataSet.IndexName := IndexName;
    Internal_SetColumnsIcons(Fields, AscIdx, DescIdx)
  finally
    Fields.Free;
  end;
end;

procedure TDBGridHelper.ClearSort;
var
  DataSet: TBufDataset;
  Fields: TStringList;
begin
  if not Assigned(DataSource.DataSet) or
     not DataSource.DataSet.Active or
     not (DataSource.DataSet is TBufDataset) then
    Exit;
  DataSet := DataSource.DataSet as TBufDataset;

  DataSet.IndexName := '';

  Fields := TStringList.Create;
  try
    Internal_SetColumnsIcons(Fields, -1, -1)
  finally
    Fields.Free
  end
end;

To use sorting you need to call helper methods in OnCellClick and onTitleClick. OnTitleClick - If you hold shift ads new column to sot list ore changes direction to selected column or just sorts one column OnCellClick - If you double click on cell[0, 0] grid clears its sorting

procedure TForm1.grdCountriesCellClick(Column: TColumn);
begin
  if not Assigned(Column) then
    grdCountries.ClearSort
end;

procedure TForm1.grdCountriesTitleClick(Column: TColumn);
begin
  grdCountries.Sort(Column.Field.FieldName, 0, 1);
end;

If you have assigned TitleImageList then you can specify which image use for ascending and which for descending operations.

ZMSQL

Another, often better way to write in-memory databases is to use the ZMSQL package:

• ZMSQL
• http://sourceforge.net/projects/lazarus-ccr/files/zmsql/
• http://www.lazarus.freepascal.org/index.php/topic,13821.30.html

Contributors

Original text written by: Zlatko Matić (matalab@gmail.com)

Other contributions by contributors as shown in the page History.