Question

我正在尝试这样做：Is it possible to Alpha Blend a VCL control on a TForm 对于阻力和放下一个带有控件的面板。 @tondrej的this answer效果很好，但TEdit或TMemo等控件使用默认的非主题边框绘制。

结果：

我的代码：

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, XPMan;

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

  TForm1 = class(TForm)
    XPManifest1: TXPManifest;
    Panel1: TPanel;
    Edit1: TEdit;
    Button1: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure Panel1StartDrag(Sender: TObject;
      var DragObject: TDragObject);
  private
    FDragImages: TDragImageList;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

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

type
  TControlProc = 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 DisplayDragImage(Control: TControl);
begin
  Control.ControlStyle := Control.ControlStyle + [csDisplayDragImage];
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FDragImages := nil;
  // set display drag image style
  IterateControls(Self, DisplayDragImage);
end;

procedure TForm1.Panel1StartDrag(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;
    Image.Canvas.Lock; // must lock the canvas!
    TPanel(Sender).PaintTo(Image.Canvas, 0, 0);
    Image.Canvas.Unlock;

    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.

我调查了TWinControl.PaintTo，但我不知道该怎么办才能让它发挥作用。我知道适用于较新版本，因为答案中的图像显然会为绘制到位图中的Edit1控件创建主题边框。

我该怎么做才能解决这个问题？

Answer 1

我研究了一个较新版本的Delphi并制作了适用于D7的程序。我不确定版权问题，所以如果有问题我会删除代码。

procedure WinControl_PaintTo(AControl: TWinControl; DC: HDC; X, Y: Integer);
  procedure DrawThemeEdge(DC: HDC; var DrawRect: TRect);
  var
    Details: TThemedElementDetails;
    Save: Integer;
  begin
    Save := SaveDC(DC);
    try
      with DrawRect do
        ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
      Details := ThemeServices.GetElementDetails(teEditTextNormal);
      ThemeServices.DrawElement(DC, Details, DrawRect);
    finally
      RestoreDC(DC, Save);
    end;
    InflateRect(DrawRect, -2, -2);
  end;
var
  I, EdgeFlags, BorderFlags, SaveIndex: Integer;
  R: TRect;
  LControl: TControl;
begin
  with AControl do
  begin
    ControlState := ControlState + [csPaintCopy];
    SaveIndex := SaveDC(DC);
    try
      MoveWindowOrg(DC, X, Y);
      IntersectClipRect(DC, 0, 0, Width, Height);
      BorderFlags := 0;
      EdgeFlags := 0;
      if GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_CLIENTEDGE <> 0 then
      begin
        EdgeFlags := EDGE_SUNKEN;
        BorderFlags := BF_RECT or BF_ADJUST
      end else
      if GetWindowLong(Handle, GWL_STYLE) and WS_BORDER <> 0 then
      begin
        EdgeFlags := BDR_OUTER;
        BorderFlags := BF_RECT or BF_ADJUST or BF_MONO;
      end;
      if (EdgeFlags = EDGE_SUNKEN) and ThemeServices.ThemesEnabled and
        not ((csDesigning in ComponentState)) then
      begin
        // Paint borders themed.
        SetRect(R, 0, 0, Width, Height);
        if csNeedsBorderPaint in ControlStyle then
          DrawThemeEdge(DC, R)
        else
        begin
          ControlStyle := ControlStyle + [csNeedsBorderPaint];
          DrawThemeEdge(DC, R);
          ControlStyle := ControlStyle - [csNeedsBorderPaint];
        end;
        MoveWindowOrg(DC, R.Left, R.Top);
        IntersectClipRect(DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
      end
      else if BorderFlags <> 0 then
      begin
        SetRect(R, 0, 0, Width, Height);
        DrawEdge(DC, R, EdgeFlags, BorderFlags);
        MoveWindowOrg(DC, R.Left, R.Top);
        IntersectClipRect(DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
      end;
      Perform(WM_ERASEBKGND, DC, 0);
      Perform(WM_PAINT, DC, 0);
      if ControlCount <> 0 then
        for I := 0 to ControlCount - 1 do
        begin
          LControl := Controls[I];
          if (LControl is TWinControl) and (LControl.Visible) then
            WinControl_PaintTo(TWinControl(LControl), DC, LControl.Left, LControl.Top);
        end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    ControlState := ControlState - [csPaintCopy];
  end;
end;

请注意，即使是Delphi的实现也不会为TEdit和TMemo绘制正确的主题边框：

原始小组：

使用PaintTo的结果：

TWinControl.PaintTo不适用于D7中带边框的主题控件

1 个答案: