TWinControl.PaintToは、D7でボーダー付きテーマコントロールではうまく機能しません。

Question

私はこれを試しています：Is it possible to Alpha Blend a VCL control on a TForm ドラッグ用&コントロール付きパネルをドロップします。 @Tndrejは、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で動作するプロシージャを作成しました。私はここで著作権問題についてはわからないので、問題があればコードを削除します。でも、Delphiの実装はTEditとTMemoため正しいテーマに境界線を描画していないこと

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; 

注：

オリジナルパネル：PaintToと

結果：