Mirror

Reorder the items of a TCheckListBox by using drag and drop (Views: 43)


Problem/Question/Abstract:

How to reorder the items of a TCheckListBox by using drag and drop

Answer:

unit PBReorderCheckListBox;

interface

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

type
  TPBReorderCheckListBox = class(TCheckListBox)
  private
    FDragIndex: Integer;
    FDragImage: TDragImagelist;
  protected
    procedure DoStartDrag(var DragObject: TDragObject); override;
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean); override;
  public
    procedure DefaultDragOver(Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean); virtual;
    procedure DefaultStartDrag(var DragObject: TDragObject); virtual;
    procedure DefaultDragDrop(Source: TObject; X, Y: Integer); virtual;
    procedure CreateDragImage(const S: string);
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    function GetDragImages: TDragImagelist; override;
    property DragIndex: Integer read FDragIndex;
    property DragImages: TDragImageList read GetDragImages;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('PBGoodies', [TPBReorderCheckListBox]);
end;

procedure TPBReorderCheckListBox.CreateDragImage(const S: string);
var
  size: TSize;
  bmp: TBitmap;
begin
  if not Assigned(FDragImage) then
    FDragImage := TDragImagelist.Create(self)
  else
    FDragImage.Clear;
  Canvas.Font := Font;
  size := Canvas.TextExtent(S);
  FDragImage.Width := size.cx;
  FDragImage.Height := size.cy;
  bmp := TBitmap.Create;
  try
    bmp.Width := size.cx;
    bmp.Height := size.cy;
    bmp.Canvas.Font := Font;
    bmp.Canvas.Font.Color := clBlack;
    bmp.Canvas.Brush.Color := clWhite;
    bmp.Canvas.Brush.Style := bsSolid;
    bmp.Canvas.TextOut(0, 0, S);
    FDragImage.AddMasked(bmp, clWhite);
  finally
    bmp.free
  end;
  ControlStyle := ControlStyle + [csDisplayDragImage];
end;

procedure TPBReorderCheckListBox.DefaultDragDrop(Source: TObject; X, Y: Integer);
var
  dropindex, ti: Integer;
  S: string;
  obj: TObject;
  checkedstate: Boolean;
begin
  if Source = Self then
  begin
    S := Items[FDragIndex];
    obj := Items.Objects[FDragIndex];
    checkedstate := Checked[FDragIndex];
    dropIndex := ItemAtPos(Point(X, Y), True);
    ti := TopIndex;
    if dropIndex > FDragIndex then
      Dec(dropIndex);
    Items.Delete(FDragIndex);
    if dropIndex < 0 then
      dropindex := items.AddObject(S, obj)
    else
      items.InsertObject(dropIndex, S, obj);
    Checked[dropindex] := checkedstate;
    TopIndex := ti;
  end;
end;

procedure TPBReorderCheckListBox.DefaultDragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source = Self;
  if Accept then
  begin
    {Handle autoscroll in the "hot zone" 5 pixels from top or bottom of client area}
    if (Y < 5) or ((ClientHeight - Y) <= 5) then
    begin
      FDragImage.HideDragImage;
      try
        if Y < 5 then
        begin
          Perform(WM_VSCROLL, SB_LINEUP, 0);
          Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
        end
        else if (ClientHeight - Y) <= 5 then
        begin
          Perform(WM_VSCROLL, SB_LINEDOWN, 0);
          Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
        end
      finally
        FDragImage.ShowDragImage;
      end;
    end;
  end;
end;

procedure TPBReorderCheckListBox.DefaultStartDrag(var DragObject: TDragObject);
begin
  FDragIndex := ItemIndex;
  if FDragIndex >= 0 then
    CreateDragImage(Items[FDragIndex])
  else
    CancelDrag;
end;

procedure TPBReorderCheckListBox.DoStartDrag(var DragObject: TDragObject);
begin
  if Assigned(OnStartDrag) then
    inherited
  else
    DefaultStartDrag(DragObject);
end;

procedure TPBReorderCheckListBox.DragDrop(Source: TObject; X, Y: Integer);
begin
  if Assigned(OnDragDrop) then
    inherited
  else
    DefaultDragDrop(Source, X, Y);
end;

procedure TPBReorderCheckListBox.DragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  if Assigned(OnDragOver) then
    inherited
  else
    DefaultDragOver(Source, X, Y, State, Accept);
end;

function TPBReorderCheckListBox.GetDragImages: TDragImagelist;
begin
  Result := FDragImage;
end;

end.

<< Back to main page