拖动网格时拖动图像更改

Posted 2023-05-08

【中文标题】拖动网格时拖动图像更改

【英文标题】：Drag image change while drag over grid

【发布时间】：2011-09-30 11:46:10

【问题描述】：

我正在 StartDrag 上创建自定义 DragObject 的实例：

procedure TForm1.GridStartDrag(Sender: TObject;
  var DragObject: TDragObject);
begin
  DragObject := TMyDragControlObject.Create(Sender as TcxGridSite);
end;

最近在 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;

我的 DragOverPaint 程序：

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;

我希望它根据网格记录值重新绘制 DragImageList，但图像列表在已经绘制时不会刷新。

【问题讨论】：

一个很好的拖放教程是Brian Long's，虽然它不涉及在拖动时更改拖动图像。

【参考方案1】：

一旦 ImageList 开始拖动，您将无法通过更改 ImageList 来更改拖动图像，因为 Windows 会专门为拖动创建另一个临时混合的 ImageList。所以你要结束，改变，重新开始ImageList拖动（这不等于结束和开始完整的VCL拖动操作，只是WinAPI ImageList）。结果/缺点是在图像的过渡处轻微颤抖。

更改图像的时刻是 Accepted 更改（在此特定情况下）。可以在 OnDragOver 中处理这个问题，但是由于您已经创建了自己的 DragObject，您也可以重写为此设计的 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;

【参考方案2】：

作为NGLNpointed out，更改没有生效的原因是Windows在拖动时创建了一个临时图像列表。作为一个稍微不同的解决方案，您可以直接更改此临时列表中的图像。

以下是相应修改的DragOverPaint。请注意，您仍然应该使用某种标志来避免每次鼠标移动都像 NGLN 的回答那样重新填充列表。

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;