Reorder the items of a TCheckListBox by using drag and drop (Views: 29)
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. |