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

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

Portail de la base de données

Références: Information générale Bibliothèques Types de champ Contrôles FAQ Comment faire en SQL ? Travailler avec TSQLQuery Applications de base de données en mémoire Tutoriels/articles pratiques : Vue d'ensemble 0 - Configuration de la base de données 1 - Commençons 2 - Edition 3 - Requêtes 4 - Modules de données Référence de programmation SQLdb Bases de données Advantage - MySQL - MSSQL - Postgres - Interbase - Firebird - Oracle - ODBC - Paradox - SQLite - dBASE - MS Access - Zeos

Introduction

Dans certaines circonstances, il est pertinent d'utiliser des DaatSets en mémoire. Si vous cherchez une base de donnée rapide, pour un utilisateur unique, un besoin non critique, sans SQL ni transaction, TMemDataset est fait pour vous.

Certains bénéfices sont :

• Une exécution rapide. Comme tout les traitements sont réalisés en mémoire, aucune donnée ne sont enregistrées sur disque sauf si explicitement demandé. La mémoire est manifestement plus rapide que le disque dur.
• Aucun besoin en bibliothèque externe (pas de fichier .so ou .dll), aucun besoin d'installer un serveur.
• Le code est multi plate-forme et peut être compilé sur n'importe quel système d'exploitation instantanément.
• Puisque toute la programmation est faite en Lazarus/FPC, de telles applications sont faciles à maintenir. En évitant de basculer constamment entre la programmation de back-end et celle de front-end, en utilisant des MemDataSets vous pouvez vous concentrer sur votre code Pascal.

  Remarque: Plus tard dans cet article est introduit le BufDataset. TBufDataset est souvent un meilleur choix que TMemDataset.

J'illustrerai comment programmer des bases de données relationnelles non-SQL en mémoire, en me concentrant sur le respect de l'intégrité et le filtrage, la simulation des champs clé primaire auto-incrémentés et autres.

Cette page partage avec vous ce que j'ai appris en expérimentant avec les TMemDatasets. Il peut y avoir certaines autres façons de faire, plus efficaces. Si tel est le cas, merci de contribuer à ce document pour le bénéfice de la communauté Lazarus/FPC.

C'est l'unité memds qui fournit TMemDataset, vous devrez donc l'ajouter dasn vos clauses uses.

Enregistrer des MemDatasets dans des fichiers persistants

Dans la partie interface de votre code, déclarez un type tableau pour stocker l'information sur les TMemDataSets que vous vloulez rendre persistant à la fin de la session et restaurer au début de la prochaine session. Vou devez déclarer aussi une variable de type TSaveTables.

J'utilise aussi une variable globale vSuppressEvents de type booléen, pour les événements de suppression utilisés pour le respect de l'intégrité référentielle, pendant la restauration des données.

Vous obtenez ceci :

type
  TSaveTables=array[1..15] of TMemDataset;    
var
  //Global variable that holds tables for saving/restoring session
  vSaveTables:TSaveTables;                  
  //Suppress events flag variables. Used during data loading from files.
  vSuppressEvents:Boolean;

Au lieu d'utiliser une variable globale comme je l'ai fait, vous pourriez la mettre sous forme d'une propriété de la fiche. TMemDataset donne une façon d'enregistrer nativement les données dans un fichier persistant : la méthode SaveToFile. Mais vous pouvez préférer sauver les données dans un fichier CSV pour un usage externe plus facile. Par conséquent, je vais combiner les deux méthodes dans les mêmes procédures. Je définis une constante cSaveRestore dans la partie Interface, par laquelle je peux définir si les données sont stockées et chargées comme fichiers natifs MemDataset ou comme fichiers CSV.

const
  //Constant cSaveRestore determines the way for saving and restoring of MemDatasets to persistent files
  cSaveRestore=0; //0=MemDataset native way, 1=saving and restoring from CSV

Maintenant, vous pouvez enregistrer les MemDatasets sur l'événement FormClose et les charger sur l'événement FormCreate. Instantiez également les éléments du tableau de MemDatasets sur l'événement FormCreate aussi.

procedure TMainForm.FormCreate(Sender: TObject);
begin
  //List of tables to be saved/restored for a session
  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;
  //Restore session
  RestoreSession;
  GetAutoincrementPrimaryFields;
end;

procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
 //Save memdatasets to files (to save current session)
 SaveSession;
end;

procedure RestoreSession;
var
  I:Integer;
begin
  try
    MemoMessages.Append(TimeToStr(Now())+' Starting restoration of previously saved session.');
    vSuppressEvents:=True; //Supress events used for referential integrity enforcing
    //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;
    //Load memdatasets from files (to restore previous session)
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].First;
      MemoMessages.Append(TimeToStr(Now())+' Starting restoration of table: '+vSaveTables[I].Name);
      try
        //If data is loaded from a csv file, then table must be deleted first.
        if cSaveRestore=1 then begin
          MemoMessages.Append(TimeToStr(Now())+' Starting delete of all records in table: '+vSaveTables[I].Name);
          //This way of deleting all records is incredibly slow.
          {while not vSaveTables[I].EOF do begin
            vSaveTables[I].Delete;
          end;}
          //This method for deleting of all records is much faster
          EmptyMemDataSet(vSaveTables[I]);
          MemoMessages.Append(TimeToStr(Now())+' All records from table: '+vSaveTables[I].Name+' deleted.');
        end;
      except
        on E:Exception do begin
          MemoMessages.Append(TimeToStr(Now())+' Error while deleteing records from table: '+vSaveTables[I].Name +'. '+E.Message);
        end;
      end;
      try
        try
          MemoMessages.Append(TimeToStr(Now())+' Restoring table: '+vSaveTables[I].Name);
          //Check constant for way of saving/restoring data and load saved session
          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())+' Error while restoring table: '+vSaveTables[I].Name +'. '+E.Message);
          end;
        end;
      finally
        vSaveTables[I].Active:=True;//Needed because of LoadFromFile method....
      end;
      MemoMessages.Append(TimeToStr(Now())+' Table: '+vSaveTables[I].Name+' restored.');
    end;
  finally
    vSuppressEvents:=False;
    //Refresh all datasets  and enable controls
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].Refresh; //Needed for tables that are filtered.
      vSaveTables[I].EnableControls;
    end;
     MemoMessages.Append(TimeToStr(Now())+' All tables restored from saved files.');
  end;
end;

procedure SaveSession;
var
  I:Integer;
begin
  try
    MemoMessages.Append(TimeToStr(Now())+' Starting saving session to persistent files.');
    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;
    //Save session to file
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].First;
      MemoMessages.Append(TimeToStr(Now())+' Saving table: '+vSaveTables[I].Name);
      try
        //Check constant for way of saving/restoring data and save session
        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())+' Error while saving table: '+vSaveTables[I].Name +'. '+E.Message);
        end;
      end;
      MemoMessages.Append(TimeToStr(Now())+' Table: '+vSaveTables[I].Name+' saved.');
    end;
  finally
    vSuppressEvents:=False;
    //Refresh all datasets  and enable controls
    for I:=Low(vSaveTables) to High(vSaveTables) do begin
      vSaveTables[I].Refresh; //Needed for tables that are filtered
      vSaveTables[I].EnableControls;
    end;
     MemoMessages.Append(TimeToStr(Now())+' All tables saved to files.');
  end;
end;

procedure EmptyMemDataSet(DataSet:TMemDataSet);
var
  vTemporaryMemDataSet:TMemDataSet;
  vFieldDef:TFieldDef;
  I:Integer;
begin
  try
    //Create temporary MemDataSet
    vTemporaryMemDataSet:=TMemDataSet.Create(nil);
    //Store FieldDefs to Temporary 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;
    //Clear existing fielddefs
    DataSet.Clear;
    //Restore 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
    //Assign SdfDataSetTemporary
    with SdfDataSetTemporary do begin
      Active:=False;
      ClearFields;
      FileName:=DataSet.Name+'.txt';
      FirstLineAsSchema:=True;
      Active:=True;
      //Determine number of fields
      vFieldCount:=FieldDefs.Count;
    end;
    //Iterate through SdfDataSetTemporary and insert records into MemDataSet
    SdfDataSetTemporary.First;
    while not SdfDataSetTemporary.EOF do begin
      DataSet.Append;
      //Iterate through 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())+' Error while setting value for field: '
             +DataSet.Name+'.'+DataSet.Fields[I].Name +'. '+E.Message);
          end;
        end;
      end;
      try
        DataSet.Post;
      except
        on E:Exception do begin
          MemoMessages.Append(TimeToStr(Now())+' Error while posting record to table: '
           +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';
  //create a new file
  AssignFile(myTextFile, myFileName);
  Rewrite(myTextFile);
  s := ''; //initialize empty string
  try
    //write field names (as column headers)
    for i := 0 to DataSet.Fields.Count - 1 do
      begin
        s := s + Format('%s,', [DataSet.Fields[i].FieldName]);
      end;
    Writeln(myTextFile, s);
    DataSet.First;
    //write field values
    while not DataSet.Eof do
      begin
        s := '';
        for i := 0 to DataSet.FieldCount - 1 do
          begin
            //Numerical fields without quotes, string fields with quotes
            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;

Clés primaires auto-incrémentées

Le champ de type auto-incrémenté n'est pas supporté par TMemDataset. Néanmoins, vous pouvez le simuler en utilisant un champ de type entier et en fournissant un procédé de calcul pour les champs auto-incrémentés. Nous avons besoin de variables globales ou propriétés publiques pour le stockage de la valeur du champ. Je préfère les variables globales, déclarées dans la partie Interface.

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;

Ensuite nous avons une procédure pour le calcul des valeurs du champ auto-incrémenté :

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;

La procédure GetAutoincrementPrimaryFields est appelées chaque fois après que vous restaurez (chargez) les données depuis des fichiers persistants, pour charger les dernières valeurs auto-incrémentées dans les variables globales (ou les propriétés si vous préférez). L'auto-incrémentation est faite dans l'événement OnNewRecord de chaque MemDataSet. Par exemple, pour le 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;

Comme précédemment expliqué, j'utilise la variable globale vSuppressEvents comme drapeau pour le cas de la restauration dees données depuis les fichiers persistants.

Faire respecter l'intégrité référentielle

Il n'y a pas de respect de l'intégrité référentielle implémenté dans le composant MemDataSet, donc vous devez le faire par vous-même.

Supposons que nous avons deux tables : MasterTable and DetailTable. Il y a divers endroits où le code d'intégrité référentielle demande à être utilisé :

• Le code d'insertion/de mise à jour est logé dans l'événement BeforePost de DetailTable : avant que l'enregistrement de détail nouveau/modifié ne soit posté/enregistré, il a besoin d'être contrôlé pour se plier aux exigences de l'intégrité référentielle (i.e. la clé du DetailTable doit exister comme clé étrangère dans MasterTable).
• Le code de suppression est logé dans l'événement BeforeDelete de la table MasterTable : avant que l'enregistrement maître soit supprimé, il a besoin d'être sûr que ses enregistrements détails vérifient les exigences d'intégrité référentielle (i.e. qu'ils soient supprimés).

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;

Après que vous ayez fourni les insertion/mise jour/suppression référentielles, tout ce que vous devez faire est de filtrer les données. Vous faites ceci avec l'événement AfterScroll de MasterTable et dans l'événement OnFilter de DetailTable.

N'oubliez pas de définir la propriété Filtered de DetailTable à '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;

Problèmes connus

Il y a plusieurs limitations dans l'utilisation des MemDatasets.

• La méthode Locate ne fonctionne pas.
• Le filtrage utilisant les propriétés Filter et Filtered ne fonctionne pas, vous devez utiliser du code en dur dans l'événement OnFilter.
• Une boucle de suppression des enregistrements semble être incroyablement lente. Donc j'utilise ma procédure EmptyMemDataset au lieu de while not EOF do Delete;.
• Dans FPC 2.6.x et antérieur, la méthode CopyFromDataSet copie uniquement les enregistrements depuis la position actuelle du curseur jusqu'à la fin du DataSet source. Donc, vous devez faire un MemDataset1.First; avant MemDataSet2.CopyFromDataSet(MemDataset1);. Cela a été corrigé dans le tronc de la révision 26233.
  • Remarquez qu'il n'y a pas (encore) de CopyFromDataset dans Bufdataset, c'est donc actuellement un avantage pour MemDS.
  • Voir le rapport de bug.

TBufDataSet

Comme indiqué auparavant, MemDataSet est privé de filtre personnalisé, de type auto-incrémenté et de méthode Locate, il est donc mieux d'utiliser TBufDataSet à la place. TBufDataset est fourni par l'unité BufDataset.

Puisqu'il n'y a pas de composant pour l'édition du TBufDataSet en conception (mais vous pouvez définir les champs lors de la conception), vous pouvez par le code créer un composant personnalisé enveloppe (wrapper) ou l'utiliser, à la manière de ClientDataSet dans Delphi. Consultez la documentation des ClientDataSet de Delphi pour les détails.

Vous pouvez utiliser les mêmes méthodes pour faire respecter l'intégrité référentielle et les champs auto-incrémentés de clé primaire comme expliqué dans MemDataSet.

Il y a seulement de petites différences entre MemDataSet et BufDataset :

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

Trier un DBGrid sur l'événement TitleClick pour un TBufDataSet

Si vous souhaitez activer le tri ascendant et descendant consécutivement dans un DBGrid montrant des données depuis un TBufDataSet, vous pourrez utiliser la méthode suivante :

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;

Ainsi, vous pouvez appeler cette fonction depuis un DBGride de cette manière :

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

Tri sur des colonnes multiples dans un DBGrid

J'ai écrit TDBGridHelper pour le tri d'une grille par des colonnes multiples entre tenant enfoncé la touche majuscule (shift).

Reamrquez que MaxIndexesCount doit être défini plutôt grand pour TBufDataSet parce qu'il peut y avoir de larges combinaisons d'options de tri possibles. Mais je pense que les gens ne voudront pas en utiliser plus de 10 donc la mettre à 100 devrait théoriquement suffire.

  { TDBGridHelper }

  TDBGridHelper = class helper for TDBGrid
  public const
    cMaxColCOunt = 3;
  private
    procedure Internal_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.Internal_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;

Pour utiliser le tri, vous avez besoin d'appeler les méthode du helper dans OnCellClick et onTitleClick.

• OnTitleClick - Si vous tenez enfoncé 'shift', pour ajouter une nouvelle colonne à la liste de tri ou changer le sens du tri ou seulement trier sur une colonne
• OnCellClick - Si vous double-cliquez sur la cellule cell[0, 0] de la grille, cela efface le tri.

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;

Si vous avez affecté TitleImageList, alors vous pouvez spécifier quelle image utiliser pour le tri ascendant et quelle autre pour le tri descendant.

ZMSQL

Une autre façon, souvent meilleure, de travailler avec des bases de données en mémoire consiste à utiliser le paquet ZMSQL :

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

Contributeurs

Texte original écrit par : Zlatko Matić (matalab@gmail.com) Les autres contributions sont données dans la page Historique.