DRAG'N DROP ENTRE 2 CONTRÔLES DE MÊME NATURE

//
//   Auteur        : Delphiprog
//   E-mail        :
//   Internet      : http://www.delphiprog.fr.fm
//   Date création : 29/08/2002
//   Date révision : 13/03/2003
{
}
//   Objet         :
{       - Démo de recherche de chaînes dans d'autres chaînes
          à l'aide d'un masque. Le code de recherche de chaînes selon un modèle
          (pattern) n'est pas de moi.
        - utilisation du drag'n drop entre deux composants TListBox et
          dans une même TListBox, dans un sens comme dans l'autre.
}
//   Remarques     :
{
}
unit UDragDropDemoForm;

interface

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

type
  TDragDropDemoForm = class(TForm)
    btnVerifyMatching: TButton;
    lbxChoix: TListBox;
    Edit1: TEdit;
    chbxCasse: TCheckBox;
    Label1: TLabel;
    Label2: TLabel;
    lbxSelectionne: TListBox;
    Label3: TLabel;
    StatusBar1: TStatusBar;
    Label4: TLabel;
    procedure btnVerifyMatchingClick(Sender: TObject);
    procedure lbxSelectionneDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure lbxSelectionneDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure lbxSelectionneStartDrag(Sender: TObject;
      var DragObject: TDragObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;

var
  DragDropDemoForm: TDragDropDemoForm;
  //Position de départ d'une opération de Drag'n drop
  StartPos,
  //index de l'élément de destination du drag'n drop
  EndPos: integer; 

implementation

{$R *.DFM}

ResourceString
  sStringsFound = '%d chaîne(s) trouvée(s)';

{-----------------------------------------------------------------------------
  Procedure: MatchStrings
  Author:    ???
  Date:      16-janv.-2003
  Arguments: source, pattern: string
  Result:    Boolean
  Objet : Rechercher dans source si le modéle pattern transmis
          correspond.
-----------------------------------------------------------------------------}

function MatchStrings(source, pattern: string): Boolean;
var
  pSource: array[0..255] of Char;
  pPattern: array[0..255] of Char;

  function MatchPattern(element, pattern: PChar): Boolean;

    function IsPatternWild(pattern: PChar): Boolean;
    begin
      Result := StrScan(pattern, '*') <> nil;
      if not Result then
        Result := StrScan(pattern, '?') <> nil;
    end;

  begin
    if 0 = StrComp(pattern, '*') then
      Result := True
    else
      if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
        Result := False
      else
        if element^ = Chr(0) then
          Result := True
        else
        begin
          case pattern^ of
            '*':
              if MatchPattern(element, @pattern[1]) then
                Result := True
              else
                Result := MatchPattern(@element[1], pattern);
            '?': Result := MatchPattern(@element[1], @pattern[1]);
          else
            if element^ = pattern^ then
              Result := MatchPattern(@element[1], @pattern[1])
            else
              Result := False;
          end;
        end;
  end;
begin
  StrPCopy(pSource, source);
  StrPCopy(pPattern, pattern);
  Result := MatchPattern(pSource, pPattern);
end;

procedure TDragDropDemoForm.btnVerifyMatchingClick(Sender: TObject);
var
  i: integer;
begin
  with LbxChoix do
    //Parcourir la liste
    for i := 0 to Items.Count - 1 do
    begin
      //Déselectionner chaque élément
      Selected[i] := False;
      //S'il faut vérifier la casse des caractères...
      if chbxCasse.Checked then
      begin
        //...transmettre les chaines tel quel
        if MatchStrings(Items[i], Edit1.Text) then
          Selected[i] := True;
      end
      else
        //...ou effectuer la comparaison sur les majuscules
        if MatchStrings(UpperCase(Items[i]), UpperCase(Edit1.Text)) then
          Selected[i] := True;
    end;
  Label2.Caption := Format(sStringsFound, [lbxChoix.SelCount]);
end;

procedure TDragDropDemoForm.lbxSelectionneDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  //Accepter l'opération SSI le contrôle de départ est un TListBox
 Accept := (Source is TListBox) and (TListBox(Source).ItemIndex <> -1);
end;

procedure TDragDropDemoForm.lbxSelectionneDragDrop(Sender, Source: TObject; X, Y: Integer);
var
  { utilisé pour ItemAtPos pour connaître l'indice de l'élément
    sur lequel on va lâcher un élément }
  APoint: TPoint; 
begin
  APoint.X := X;
  APoint.y := Y;
  //Si l'élément tiré est issu d'une autre listbox...
  if Sender <> Source then
  begin
    //Insérer l'élément à la position courante
    with TListBox(Sender) do
      Items.Insert(ItemAtPos(APoint, True),
        TListBox(Source).Items[TListBox(Source).ItemIndex]);
    //et le supprimer de la ListBox d'origine
    with TListBox(Source) do
      Items.Delete(ItemIndex);
  end
  else
    //Un élément va être relâché sur la même ListBox
    with TListBox(Source) do
    begin
      //Calcul de l'indice de l'élément de destination
      EndPos := ItemAtPos(APoint, True);
      //Déplacer l'élément de son ancienne position à la nouvelle
      Items.Move(StartPos, EndPos);
    end;
end;

procedure TDragDropDemoForm.lbxSelectionneStartDrag(Sender: TObject;
  var DragObject: TDragObject);
begin
  { Déterminer la position de départ de
    l'opération de tirer/Lâcher }
  StartPos := TListBox(Sender).ItemIndex;
end;

end.