begin process at 2012 02 05 01:01:37
  Trouver un code source :
 
dans
 
Accueil > 

Code

 > 

Trucs & Astuces

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

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


 Information sur la source

Note :
10 / 10 - par 1 personne
10,00 / 10

  • 1

  • 2

  • 3

  • 4

  • 5

  • 6

  • 7

  • 8

  • 9

  • 10
Catégorie :Trucs & Astuces Niveau :Expert Date de création :16/01/2003 Date de mise à jour :13/03/2003 19:48:56 Vu / téléchargé :6 104 / 495

Auteur : Delphiprog

Ecrire un message privé
Site perso
Commentaire sur cette source (9)
Ajouter un commentaire et/ou une note

 Description

Cliquez pour voir la capture en taille normale
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

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

 Fichier Zip

Les Membres Club peuvent télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Télécharger le zip


 Sources du même auteur

Source avec Zip TABLE DE CORRESPONDANCE TYPES DE DONNÉES API/PASCAL OBJET
Source avec Zip Source avec une capture GÉNÉRER DES PDF AVEC DELPHI ET PDF CREATOR
Source avec Zip Source avec une capture DESIGN PATTERN OBSERVER : IMPLÉMENTATION RÉUTILISABLE
Source avec Zip DESIGN PATTERN STRATÉGIE APPLIQUÉ AU CODE "JOURNAL DE DÉBUGG...
Source avec Zip Source avec une capture DESSINER UN RECTANGLE DE SÉLECTION AU DESSUS D'AUTRES COMPOS...

 Sources de la même categorie

Source avec Zip DICTIONNAIRE WORD DANS UN RICHEDIT par H60
Source avec Zip TRIER DU GREC DANS UNE APPLI EN CODE LOCAL FRANÇAIS. par fricot
Source avec Zip Source avec une capture INTÉGRATION DE PAGE HTML DANS LES RESSOURCES D'UNE DLL par christophe75018
FONCTION DE CONVERSION DE MILLISECONDES EN HH:MM:SS:MMM par vyseR
Source avec Zip Source avec une capture UTILISER UNE DLL INCLUSE EN RESSOURCES par Bacterius

Commentaires et avis

Commentaire de Bestiol le 17/01/2003 08:14:20

Voilà un code qui va permettre d'améliorer bon nombre d'interfaces !!!

Bravo ! (une fois de plus !)

Commentaire de iubito le 13/03/2003 16:22:01

je vais l'étudier de + près mais y'a quand même des bugs :
de droite à gauche, si j'ai sélectionné aucun élément --&gt; plantage
de gauche à droite, si la liste de gauche est vide --&gt; ça plante

Commentaire de Delphiprog le 13/03/2003 20:00:05 administrateur CS

Effectivement, y a un bug !
La solution : modifier les conditions d'acceptation du drag'n drop en ajoutant une condition supplémentaire :
Accept := (Source is TListBox) and (TListBox(Source).ItemIndex &lt;&gt; -1);

au lieu de mettre simplement :
Accept := (Source is TListBox) ;

Merci iubito.

Commentaire de TiDaN326 le 24/08/2004 20:03:44

en un mot, Merveilleux !

Commentaire de patricerolland le 27/10/2005 15:39:52

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

Commentaire de Delphiprog le 27/10/2005 20:09:52 administrateur CS

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.

Commentaire de helmis le 28/08/2008 10:32:00

Bonjour

Comment on fait pour un multi-delect ?

Commentaire de helmis le 28/08/2008 10:37:07

multi-select

Commentaire de Delphiprog le 28/08/2008 12:18:07 administrateur CS

Bonjour Helmis,

Je te conseille dans ce cas de te tourner vers le code source de Japee : http://tinyurl.com/66m6nf

 Ajouter un commentaire




Nos sponsors


Sondage...

Comparez les prix

CalendriCode

Février 2012
LMMJVSD
  12345
6789101112
13141516171819
20212223242526
272829    

Consulter la suite du CalendriCode

Photothèque

 
Développement réalisé par Nicolas SOREL (Nix) avec l'aide de : Cyril DURAND et Emmanuel (EBArtSoft), Merci à Vincent pour ses précieux conseils.
CodeS-SourceS.com© Toute reproduction même partielle est interdite sauf accord écrit du Webmaster
CodeS-SourceS.com© est une marque déposée tous droits réservés

Google Coop CodeS-SourceS Google Coop CodeS-SourceS
Temps d'éxécution de la page : 0,718 sec (3)

Nous contacter | Annoncer sur CodeS-SourceS | Mentions légales