delphi - 是否可以在 TForm 上对 VCL 控件进行 Alpha 混合？

Question

是否可以对 TForm 上的 VCL 控件进行 Alpha Blend 或实现类似的效果？

例如，考虑以下屏幕截图，其中两个 TPanel 放置在 TForm 上以及其他控件。两个面板都可以拖动（请参阅 如何在运行时移动和调整控件大小）。

现在，是否可以在拖动时使这些面板半透明，以便您可以看到下面的内容？（如通过图像处理产生的第二张图像所示）

Answer 1

VCL 让您有机会指定要在拖放期间使用的拖动图像列表，这是一个简单的示例：

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TPanel = class(Vcl.ExtCtrls.TPanel)
  protected
    function GetDragImages: TDragImageList; override;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    CheckBox1: TCheckBox;
    Edit1: TEdit;
    Label1: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
    procedure PanelStartDrag(Sender: TObject; var DragObject: TDragObject);
    procedure PanelEndDrag(Sender, Target: TObject; X, Y: Integer);
  private
    FDragImages: TDragImageList;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TPanel }

function TPanel.GetDragImages: TDragImageList;
begin
  Result := (Owner as TForm1).FDragImages;
end;

type
  TControlProc = reference to procedure(Control: TControl);

procedure IterateControls(Control: TControl; Proc: TControlProc);
var
  I: Integer;
begin
  if Assigned(Control) then
    Proc(Control);
  if Control is TWinControl then
    for I := 0 to TWinControl(Control).ControlCount - 1 do
      IterateControls(TWinControl(Control).Controls[I], Proc);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FDragImages := nil;
  // set display drag image style
  IterateControls(Self,
    procedure(Control: TControl)
    begin
      Control.ControlStyle := Control.ControlStyle + [csDisplayDragImage];
    end
  );
end;

procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TPanel;
end;

procedure TForm1.PanelEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
  FreeAndNil(FDragImages);
end;

procedure TForm1.PanelStartDrag(Sender: TObject; var DragObject: TDragObject);
var
  Image: TBitmap;
begin
  if not (Sender is TPanel) then
    Exit;

  Image := TBitmap.Create;
  try
    Image.PixelFormat := pf32bit;
    Image.Width := TControl(Sender).Width;
    Image.Height := TControl(Sender).Height;
    TPanel(Sender).PaintTo(Image.Canvas, 0, 0);

    FDragImages := TDragImageList.Create(nil);
    FDragImages.Width := Image.Width;
    FDragImages.Height := Image.Height;
    FDragImages.SetDragImage(FDragImages.Add(Image, nil), 0, 0);
    FDragImages.ShowDragImage;
  except
    Image.Free;
    FreeAndNil(FDragImages);
    raise;
  end;
end;

end.

Answer 2

你也可以在 Delphi 中做到这一点。基本思想是将控件放入启用了 alpha 混合的自动调整大小的边框形式。

根据您链接到的文章，在 MouseDown 事件中添加以下行：

  P := TWinControl(Sender).ClientToScreen(Point(0,0));
  frm := TForm.Create(nil);
  TWinControl(Sender).Parent := frm;
  frm.BorderStyle := bsNone;
  frm.AlphaBlend := true;
  frm.AlphaBlendValue := 128;
  frm.AutoSize := true;
  frm.Left := P.X;
  frm.Top := P.Y;
  frm.Position := poDesigned;
  frm.Show;

在 MouseMove 事件中设置控件父级的 Left 和 Top 属性：

  GetCursorPos(newPos);

  Screen.Cursor := crSize;
  Parent.Left := Parent.Left - oldPos.X + newPos.X;
  Parent.Top := Parent.Top - oldPos.Y + newPos.Y;
  oldPos := newPos;

并在 MouseUp 事件中释放表单，将控件父级设置回原始父级并将屏幕位置转换为相对于它的新位置：

frm := TWinControl(Sender).Parent;
P := Point(frm.Left, frm.Top);
P := ScreenToClient(P);
TWinControl(Sender).Parent := Self;
TWinControl(Sender).Left := P.X;
TWinControl(Sender).Top := P.Y;
frm.Free;
Screen.Cursor := crDefault;
ReleaseCapture;
inReposition := False;

Answer 3

要实现显示控件图像的拖动操作，您必须创建一个TDragControlObject后代并实现该GetDragImages方法，从这里您必须确保将csDisplayDragImage值添加到要拖动的控件的ControlStyle属性中。

您可以在此处找到有关此主题的非常好的文章Implementing Professional Drag & Drop In VCL/CLX Applications