TWinControl.PaintTo does not work well for themed controls with border in D7

Question

I'm trying do this: Is it possible to Alpha Blend a VCL control on a TForm for drag & drop a panel with controls in it. this answer by @TOndrej works well except that controls like TEdit or TMemo are painted with the default non-themed border.

The result:

My code:

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.

I looked into TWinControl.PaintTo but I don't know what to do to make it work. I know it works for newer versions because clearly the image in the answer creates themed border for the Edit1 control that was painted into the bitmap.

What can I do to fix this?

Answer 1

I looked into a newer version of Delphi and made a procedure that works for D7. I'm not sure about copyrights issue here, so if there is a problem I will remove the code.

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;

Note that even Delphi's implementation does not draw the correct themed border for TEdit and TMemo:

Original panel:

Result with PaintTo: