Apprendre le glisser-déposer avec Free Pascal/Lazarus 1/3

object MainForm: TMainForm
  Left = 327
  Height = 236
  Top = 173
  Width = 296
  Caption = 'Drag and Drop - 03'
  ClientHeight = 236
  ClientWidth = 296
  Position = poScreenCenter
  LCLVersion = '1.6.4.0'
  object lblSource: TLabel
    Left = 88
    Height = 45
    Top = 40
    Width = 97
    Caption = 'Source'
    DragMode = dmAutomatic
    Font.Height = -32
    ParentColor = False
    ParentFont = False
  end
  object lblTarget: TLabel
    Left = 88
    Height = 45
    Top = 120
    Width = 72
    Caption = 'Cible'
    Font.Height = -32
    ParentColor = False
    ParentFont = False
    OnDragDrop = lblTargetDragDrop
    OnDragOver = lblTargetDragOver
  end
end

procedure TMainForm.lblTargetDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
// *** on accepte le TLabel ***
begin
  Accept := (Source is TLabel);
end;

procedure TMainForm.lblTargetDragDrop(Sender, Source: TObject; X, Y: Integer);
// *** on change le libellé ***
begin
  (Sender as TLabel).Caption := (Source as TLabel).Caption;
end;

object MainForm: TMainForm
  Left = 256
  Height = 261
  Top = 173
  Width = 446
  Caption = 'Drag and Drop - 04'
  ClientHeight = 261
  ClientWidth = 446
  Position = poScreenCenter
  LCLVersion = '1.6.4.0'
  object GroupBox1: TGroupBox
    Left = 24
    Height = 208
    Top = 31
    Width = 184
    Caption = 'Image 1'
    ClientHeight = 188
    ClientWidth = 180
    TabOrder = 0
    object Image1: TImage
      Left = 20
      Height = 148
      Top = 20
      Width = 138
      DragMode = dmAutomatic
      OnDragDrop = Image1DragDrop
      OnDragOver = Image2DragOver
      Picture.Data = {
// les données de l'image n'ont pas été reproduites !
      }
      Stretch = True
    end
  end
  object GroupBox2: TGroupBox
    Left = 232
    Height = 208
    Top = 31
    Width = 184
    Caption = 'Image 2'
    ClientHeight = 188
    ClientWidth = 180
    TabOrder = 1
    object Image2: TImage
      Left = 20
      Height = 148
      Top = 20
      Width = 138
      DragMode = dmAutomatic
      OnDragDrop = Image1DragDrop
      OnDragOver = Image2DragOver
      Picture.Data = {
// les données de l'image n'ont pas été reproduites !
     }
      Stretch = True
    end
  end
end

procedure TMainForm.Image2DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
// *** acceptation ou refus du contrôle ***
begin
  Accept := (Source <> Sender) and ((Source = Image1) or (Source = Image2));
end;

procedure TMainForm.Image1DragDrop(Sender, Source: TObject; X, Y: Integer);
// *** le contrôle est lâché = > on échange les images ***
var
  LPct: TPicture;
begin
  LPct := TPicture.Create;
  try
    LPct.Assign((Sender as TImage).Picture);
    (Sender as TImage).Picture.Assign((Source as TImage).Picture);
    (Source as TImage).Picture.Assign(LPct);
  finally
    LPct.Free;
  end;
end;

unit main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls;

type

  { TMainForm }

  TMainForm = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    procedure Image1DragDrop(Sender, Source: TObject; {%H-}X, {%H-}Y: Integer);
    procedure Image1DragOver(Sender, Source: TObject; {%H-}X, {%H-}Y: Integer;
      {%H-}State: TDragState; var Accept: Boolean);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.lfm}

{ TMainForm }

procedure TMainForm.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
// *** survol ***  
begin
  Accept := (Source is TImage) and (Sender <> Source);
end;

procedure TMainForm.Image1DragDrop(Sender, Source: TObject; X, Y: Integer);
// *** lâcher ***
var
  LImg: TImage;
begin
  LImg := TImage.Create(nil);
  try
    LImg.Picture := (Source as TImage).Picture;
    (Source as TImage).Picture := (Sender as TImage).Picture;
    (Sender as TImage).Picture := LImg.Picture;
  finally
    LImg.Free;
  end;
end;

end.

procedure TMainForm.FormCreate(Sender: TObject);
// *** listbox complétée à la création de la fiche ***
var
  Li: Integer;
begin
  for Li := 1 to 9 do
     lbMain.Items.Add('Elément n°' + IntToStr(Li*1000 + Li*100 + Li*10 + Li));
end;

procedure TMainForm.lbMainDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
// *** seule la listbox est prise en compte ***
begin
  Accept := (Sender = Source);
end;

procedure TMainForm.lbMainDragDrop(Sender, Source: TObject; X, Y: Integer);
// *** insertion des éléments sélectionnés ***
var
  LSt: TStringList;
  Li, LIndex: Integer;
begin
  // affichage de la listbox figé pour éviter les scintillements
  (Sender as TListBox).Items.BeginUpdate;
  try
    // index du lâcher
    LIndex := (Sender as TListBox).GetIndexAtXY(X, Y);
    // liste de travail
    LSt := TStringList.Create;
    try
      // décompte pour éviter les erreurs lors de la suppression d'un élément
      for Li := (Sender as TListBox).Count - 1 downto 0 do
      begin
        // élément sélectionné ?
        if (Sender as TListBox).Selected[Li] then
        begin
          // on l'ajoute à la liste provisoire
          LSt.Add((Sender as TListBox).Items[Li]);
          // on le supprime de la listbox d'origine
          (Sender as TListBox).Items.Delete(Li);
          // on réadapte l'index pour éviter les index hors limites
          if Li <= LIndex then
            Dec(LIndex);
        end;
      end;
      // on insère les éléments déplacés à l'index visé
      for Li := 0 to LSt.Count - 1 do
        (Sender as TListBox).Items.Insert(LIndex, Lst[Li]);
    finally
      // libération de la liste de travail
      LSt.Free;
    end;
  finally
    // affichage de la lisbox actualisée
    (Sender as TListBox).Items.EndUpdate;
  end;
end;

object MainForm: TMainForm
  Left = 327
  Height = 374
  Top = 173
  Width = 331
  Caption = 'Drag and Drop - 07'
  ClientHeight = 374
  ClientWidth = 331
  LCLVersion = '1.6.4.0'
  object lbSrc: TListBox
    Left = 16
    Height = 248
    Top = 32
    Width = 120
    DragMode = dmAutomatic
    Items.Strings = (
      'essai 1'
      'essai 2'
      'essai 3'
      'essai 41'
      'essai 42'
      'essai 43'
      'essai 44'
      'essai 45'
      'essai 46'
      'essai 47'
      'essai 48'
      'essai 49'
      'essai 50'
      'essai 51'
      'essai 52'
      'essai 53'
      'essai 54'
      'essai 55'
      'essai 56'
    )
    ItemHeight = 15
    ItemIndex = 0
    MultiSelect = True
    OnDragDrop = lbSrcDragDrop
    OnDragOver = lbSrcDragOver
    OnEndDrag = lbSrcEndDrag
    OnStartDrag = lbSrcStartDrag
    TabOrder = 0
  end
  object lbDst: TListBox
    Left = 192
    Height = 248
    Top = 32
    Width = 120
    DragMode = dmAutomatic
    ItemHeight = 0
    MultiSelect = True
    OnDragDrop = lbSrcDragDrop
    OnDragOver = lbSrcDragOver
    OnEndDrag = lbSrcEndDrag
    OnStartDrag = lbSrcStartDrag
    TabOrder = 1
  end
  object sbRight: TSpeedButton
    Left = 152
    Height = 22
    Top = 80
    Width = 23
    Action = ActionRight
    Font.Style = [fsBold]
    ParentFont = False
  end
  object sbRightAll: TSpeedButton
    Left = 152
    Height = 22
    Top = 111
    Width = 23
    Action = ActionRightAll
    Font.Style = [fsBold]
    ParentFont = False
  end
  object sbLeft: TSpeedButton
    Left = 152
    Height = 22
    Top = 175
    Width = 23
    Action = ActionLeft
    Font.Style = [fsBold]
    ParentFont = False
  end
  object sbLeftAll: TSpeedButton
    Left = 152
    Height = 22
    Top = 207
    Width = 23
    Action = ActionLeftAll
    Font.Style = [fsBold]
    ParentFont = False
  end
  object sbarMain: TStatusBar
    Left = 0
    Height = 23
    Top = 351
    Width = 331
    Panels = <>
  end
  object ActionListMain: TActionList
    OnUpdate = ActionListMainUpdate
    left = 160
    top = 296
    object ActionRight: TAction
      Caption = '>'
      OnExecute = ActionRightExecute
    end
    object ActionLeft: TAction
      Caption = '<'
      OnExecute = ActionLeftExecute
    end
    object ActionRightAll: TAction
      Caption = '>>'
      OnExecute = ActionRightAllExecute
    end
    object ActionLeftAll: TAction
      Caption = '<<'
      OnExecute = ActionLeftAllExecute
    end
  end
end

procedure TMainForm.ActionListMainUpdate(AAction: TBasicAction;
  var Handled: Boolean);
// *** mise à jour des boutons ***
begin
  sbRight.Enabled := (lbSrc.Items.Count <> 0);
  sbRightAll.Enabled := sbRight.Enabled;
  sbLeft.Enabled := (lbDst.Items.Count <> 0);
  sbLeftAll.Enabled := sbLeft.Enabled;
end;

procedure TMainForm.ActionRightAllExecute(Sender: TObject);
// *** tout déplacer vers la droite ***
begin
  lbSrc.SelectAll;
  MoveItems(lbDst.Count, lbSrc, lbDst);
  HighlightedItem(lbDst);
end;

procedure TMainForm.ActionLeftExecute(Sender: TObject);
// *** déplacement vers la gauche ***
begin
  MoveItems(lbSrc.Count, lbDst, lbSrc);
  HighlightedItem(lbSrc);
  HighlightedItem(lbDst);
end;

procedure TMainForm.ActionLeftAllExecute(Sender: TObject);
// *** tout déplacer vers la gauche ***
begin
  lbDst.SelectAll;
  MoveItems(lbSrc.Count, lbDst, lbSrc);
  HighlightedItem(lbSrc);
end;

procedure TMainForm.ActionRightExecute(Sender: TObject);
// *** déplacement vers la droite ***
begin
  MoveItems(lbDst.Count, lbSrc, lbDst);
  HighlightedItem(lbSrc);
  HighlightedItem(lbDst);
end;

procedure TMainForm.HighlightedItem(List: TListBox);
// *** élément en surbrillance par défaut ***
var
  LIndex: Integer;
begin
  LIndex := StartOfSelection(List);
  if List.Count > 0 then
  begin
    List.SetFocus;
    if LIndex < - 1 then
      LIndex := 0
    else
    if LIndex > List.Count - 1 then
      LIndex := List.Count - 1;
    List.Selected[LIndex] := True;
  end;
end;

procedure TMainForm.MoveItems(Index: Integer; AFromListBox, AToListBox: TListBox);
// *** déplacement d'éléments ***
var
  LI: Integer;
begin
  if Index < 0 then
    Index := 0;
  AFromListBox.Items.BeginUpdate;
  try
    AToListBox.Items.BeginUpdate;
    try
      for LI := AFromListBox.Count - 1 downto 0 do
        if AFromListBox.Selected[LI] then
        begin
          AToListBox.Items.Insert(Index, AFromListBox.Items[LI]);
          AFromListBox.Items.Delete(LI);
        end;
    finally
      AToListBox.Items.EndUpdate;
    end;
  finally
    AFromListBox.Items.EndUpdate;
  end;
end;

procedure TMainForm.lbSrcDragDrop(Sender, Source: TObject; X, Y: Integer);
// *** glisser-déposer ***
begin
  if (Source = Sender) then
    MoveItemsWithinList((Source as TListBox).GetIndexAtXY(X, Y), (Source as TListBox))
  else
    MoveItems((Sender as TListBox).GetIndexAtXY(X, Y), (Source as TListBox),
      (Sender as TListBox));
  HighlightedItem(lbSrc);
  HighlightedItem(lbDst);
end;

procedure TMainForm.lbSrcDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
// *** acceptation du déposer ***
begin
  Accept := (Source = lbSrc) or (Source = lbDst);
end;

procedure TMainForm.MoveItemsWithinList(Index: Integer; AListBox: TListBox);
// *** déplacement d'éléments à l'intérieur d'une liste ***
var
  LI: Integer;
  LStrList: TStringList;
begin
  LStrList := TStringList.Create;
  try
    AListBox.Items.BeginUpdate;
    try
      for LI := AListBox.Items.Count - 1 downto 0 do
        if AListBox.Selected[LI] then
        begin
          LStrList.Add(AListBox.Items[LI]);
          AListBox.Items.Delete(LI);
          if LI <= Index then
            Dec(Index);
        end;
      if Index <> -1 then
      begin
        for LI := 0 to LStrList.Count - 1 do
           AListBox.Items.Insert(Index, LStrList[LI]);
      end
      else
      begin
        for LI := LStrList.Count - 1 downto 0 do
          AListBox.Items.Add(LStrList[LI]);
      end;
    finally
      AListBox.Items.EndUpdate;
    end;
  finally
    LStrList.Free;
  end;
end;