TWinControl.PaintTo funktioniert nicht gut für themenbezogene Steuerelemente mit Rahmen in D7

Question

Ich versuche dies: Is it possible to Alpha Blend a VCL control on a TForm für ziehen & Drop ein Panel mit Steuerelementen drin. this answer von @TOndrej funktioniert gut, außer dass die Kontrollen wie TEdit oder TMemo mit der Standard-Nicht-themed Grenze gemalt werden.

Das Ergebnis:

Mein 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. 

Ich sah in TWinControl.PaintTo aber ich weiß nicht, was es Arbeit zu tun zu machen. Ich weiß, es funktioniert für neuere Versionen, weil klar das Bild in der Antwort themed Grenze für die Edit1 Steuerelement erstellt, die in die Bitmap gemalt wurde.

Was kann ich dieses Problem beheben?

Answer 1

Ich sah in eine neuere Version von Delphi und machte ein Verfahren, das für D7 funktioniert. Ich bin mir nicht sicher, ob hier Urheberrechte bestehen. Wenn es ein Problem gibt, entferne ich den 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; 

Beachten Sie, dass auch Delphi-Implementierung nicht die richtige thematische Grenze für TEdit und TMemo sich ziehen:

Original-Platte:

Ergebnis mit PaintTo: