Drag image change while drag over grid - delphi

Question

I'm creating an instance of my custom DragObject on StartDrag:
procedure TForm1.GridStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
DragObject := TMyDragControlObject.Create(Sender as TcxGridSite);
end;
Lately on another grid on DragOver:
procedure TForm1.SecondGridDragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := False;
if Source is TMyDragControlObject then
with TMyDragControlObject(Source) do
// using TcxGrid
if (Control is TcxGridSite) or (Control is TcxGrid) then begin
Accept := True
// checking the record value on grid
// the label of drag cursor will be different
// getting the record value works fine!
if RecordOnGrid.Value > 5 then
DragOverPaint(FImageList, 'You can drop here!');
else begin
Accept := false;
DragOverPaint(FImageList, 'You can''t drop here!');
end
end;
end;
My DragOverPaint procedure:
procedure TForm1.DragOverPaint(ImageList: TImageList; AValue: string);
var ABmp: TBitmap;
begin
if not Assigned(ImageList) then Exit;
ABmp := TBitmap.Create();
try
with ABmp.Canvas do begin
ABmp.Width := TextWidth(AValue);
ABmp.Height := TextHeight(AValue);
TextOut(0, 0, AValue);
end;
ImageList.BeginUpdate;
ImageList.Clear;
ImageList.Width := ABmp.Width;
ImageList.Height := ABmp.Height;
ImageList.AddMasked(ABmp, clNone);
ImageList.EndUpdate;
finally
ABmp.Free();
end;
Repaint;
end;
I want it to repaint DragImageList depending on the grid record value, but the image list doesn't refresh when it's already painted.

Answer 1

Once the ImageList has started dragging, you cannot change the drag image by changing the ImageList because Windows creates another temporarily blended ImageList specially for the dragging. So you have to end, change and start the ImageList dragging again (this is not equal to ending and starting the complete VCL dragging operation, just the WinAPI ImageList). The result/downside is a slight quiver at the transition of the images.
The moment of changing the images is when Accepted changes (in this specific case). It is possible to deal with this in OnDragOver, but since you create an own DragObject already, you can also override the therefor designed methods of TDragObject:
type
TControlAccess = class(TControl);
TMyDragControlObject = class(TDragControlObjectEx)
private
FDragImages: TDragImageList;
FPrevAccepted: Boolean;
protected
function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
function GetDragImages: TDragImageList; override;
public
destructor Destroy; override;
end;
{ TMyDragControlObject }
destructor TMyDragControlObject.Destroy;
begin
FDragImages.Free;
inherited Destroy;
end;
function TMyDragControlObject.GetDragCursor(Accepted: Boolean; X,
Y: Integer): TCursor;
begin
if FPrevAccepted <> Accepted then
with FDragImages do
begin
EndDrag;
SetDragImage(Ord(Accepted), 0, 0);
BeginDrag(GetDesktopWindow, X, Y);
end;
FPrevAccepted := Accepted;
Result := inherited GetDragCursor(Accepted, X, Y);
end;
function TMyDragControlObject.GetDragImages: TDragImageList;
const
SNoDrop = 'You can''t drop here!!';
SDrop = 'You can drop here.';
Margin = 20;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Canvas.Font.Assign(TControlAccess(Control).Font);
Bmp.Width := Bmp.Canvas.TextWidth(SNoDrop) + Margin;
Bmp.Height := Bmp.Canvas.TextHeight(SNoDrop);
Bmp.Canvas.TextOut(Margin, 0, SNoDrop);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.Add(Bmp, nil);
Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
Bmp.Canvas.TextOut(Margin, 0, SDrop);
FDragImages.Add(Bmp, nil);
FDragImages.SetDragImage(0, 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Grid1.ControlStyle := Grid1.ControlStyle + [csDisplayDragImage];
Grid2.ControlStyle := Grid2.ControlStyle + [csDisplayDragImage];
end;
procedure TForm1.Grid1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
DragObject := TMyDragControlObject.Create(Sender as TStringGrid);
end;
procedure TForm1.Grid2DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := False;
if IsDragObject(Source) then
with TMyDragControlObject(Source) do
if Control is TGrid then
{ Just some condition for testing }
if Y > Control.Height div 2 then
Accept := True;
end;

Answer 2

As NGLN pointed out, the reason for the change not taking effect is that Windows creates a temporary image list while dragging. As a slightly different solution, you can directly change the image in this temporary list.
The below is the modified DragOverPaint accordingly. Note that you should still make use of some kind of a flag for not repopulating the list with every mouse move as in NGLN's answer.
procedure TForm1.DragOverPaint(ImageList: TImageList; AValue: string);
var
ABmp: TBitmap;
ImgList: HIMAGELIST; // <- will get the temporary image list
begin
if not Assigned(ImageList) then Exit;
ABmp := TBitmap.Create();
try
with ABmp.Canvas do begin
ABmp.Width := TextWidth(AValue);
ABmp.Height := TextHeight(AValue);
TextOut(0, 0, AValue);
end;
// ImageList.BeginUpdate; // do not fiddle with the image list,
// ImageList.Clear; // it's not used while dragging
// ImageList.Width := ABmp.Width;
// ImageList.Height := ABmp.Height;
// ImageList.AddMasked(ABmp, clNone);
// ImageList.EndUpdate;
// get the temporary image list
ImgList := ImageList_GetDragImage(nil, nil);
// set the dimensions for images and empty the list
ImageList_SetIconSize(ImgList, ABmp.Width, ABmp.Height);
// add the text as the first image
ImageList_AddMasked(ImgList, ABmp.Handle, ColorToRGB(clWhite));
finally
ABmp.Free();
end;
// Repaint; // <- No need to repaint the form
end;