Drag'n drop entre 2 contrôles de même nature

Soyez le premier à donner votre avis sur cette source.

Vue 7 501 fois - Téléchargée 601 fois

Description

Démonstration du Tirer/Lâcher (drag and drop) entre :
-> 2 composants TList
-> au sein d'un même composant TList

Ce code inclut aussi une fonction de recherche de chaîne selon un masque défini par l'utilisateur, en utilisant les caractères jokers ? et *. Ce code n'est pas de moi et je ne me souviens plus de son auteur.

Source / Exemple :


//
//   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.

Conclusion :


Ce code n'implémente le Tirer/Lâcher que d'un seul élément à la fois.
Delphi 4 et +.
Utilisable avec l'édition personnelle de Delphi.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
4580
Date d'inscription
samedi 19 janvier 2002
Statut
Modérateur
Dernière intervention
9 janvier 2013
28
Bonjour Helmis,

Je te conseille dans ce cas de te tourner vers le code source de Japee : http://tinyurl.com/66m6nf
Messages postés
34
Date d'inscription
jeudi 1 juillet 2004
Statut
Membre
Dernière intervention
9 mai 2008

multi-select
Messages postés
34
Date d'inscription
jeudi 1 juillet 2004
Statut
Membre
Dernière intervention
9 mai 2008

Bonjour

Comment on fait pour un multi-delect ?
Messages postés
4580
Date d'inscription
samedi 19 janvier 2002
Statut
Modérateur
Dernière intervention
9 janvier 2013
28
Si l'erreur ne porte que sur un TLabel, je pense que tu peux cliquer sur "ignorer". Ce projet a dû être réalisé avec Delphi 6 à l'époque.
Au pire, tu supprimes les TLabel et tu les recrées vu qu'il n'y en a que trois.
Messages postés
1
Date d'inscription
vendredi 8 juillet 2005
Statut
Membre
Dernière intervention
27 octobre 2005

Lorsque que j'ouvre le projet avec Delphi5 j'ai le message d'erreur suivant :
"Erreur lors de la lecture de Label1.caption: Valeur de propriété incorrect..." que dois-je faire ?

merci Patrice
Afficher les 9 commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.