Delphi TWinControl.painto不适用于边界位于D7中的主题控件

我正在尝试这样做： 用于拖放包含控件的面板。by@TOndrej运行良好，除了

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

，但我不知道该怎么做才能让它工作。我知道它适用于较新版本，因为答案中的图像显然为绘制到位图中的

Edit1

控件创建了主题边框

---

我能做些什么来解决这个问题？

我研究了一个较新版本的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;

程序WinControl\u painto（a控制：TWinControl；DC:HDC；X，Y：整数）；
程序DrawThemeEdge（DC:HDC；var DrawRect:TRect）；
变量
详细信息：t详细信息；
保存：整数；
开始
Save:=SaveDC（DC）；
尝试
用DrawRect do
排除CLIPRECT（直流，左+2，上+2，右-2，下-2）；
详细信息：=ThemeServices.GetElementDetails（teEditTextNormal）；
ThemeServices.DrawElement（DC、详细信息、DrawRect）；
最后
恢复的DC（DC，保存）；
结束；
充气（DrawRect，-2，-2）；
结束；
变量
一、 EdgeFlags、BorderFlags、SaveIndex:Integer；
R:TRect；
l控制：t控制；
开始
用乌头
开始
ControlState:=ControlState+[csPaintCopy]；
SaveIndex:=SaveDC（DC）；
尝试
移动窗口组织（DC、X、Y）；
IntersectClipRect（DC，0，0，宽度，高度）；
边界标志：=0；
边间隙：=0；
如果GetWindowLong（句柄，GWL_EXSTYLE）和WS_EX_CLIENTEDGE为0，则
开始
边缘凹陷：=边缘凹陷；
BorderFlags:=BF\u RECT或BF\u ADJUST
结束其他
如果GetWindowLong（句柄，GWL_样式）和WS_边框为0，则
开始
边缘层：=BDR_外部；
BorderFlags:=BF_RECT或BF_ADJUST或BF_MONO；
结束；
if（EdgeFlags=EDGE_Unken）和ThemeServices.ThemesEnabled和
而不是（（csDesigning in ComponentState））那么
开始
//绘制边框主题。
SetRect（R，0，0，宽度，高度）；
如果CSE需要ControlStyle中的命令绘制，则
牵引进料（直流，右）
其他的
开始
ControlStyle:=ControlStyle+[CSneedsOrderPaint]；
拔出饲料（DC，R）；
ControlStyle:=ControlStyle-[CSneedsOrderPaint]；
结束；
移动窗口组织（DC，右左，右上）；
交叉点（DC，0，0，右-右-左，右下-右上）；
结束
否则，如果边界标记为0，则
开始
SetRect（R，0，0，宽度，高度）；
抽屉边缘（DC、R、边缘标记、边界标记）；
移动窗口组织（DC，右左，右上）；
交叉点（DC，0，0，右-右-左，右下-右上）；
结束；
执行（WM_ERASEBKGND，DC，0）；
执行（WM_油漆，直流，0）；
如果控制计数为0，则
对于I:=0到ControlCount-1 do
开始
l控制：=控制[I]；
如果（LControl是TWinControl）和（LControl.Visible），则
WinControl（双控（LControl），直流，LControl.左，LControl.上）；
结束；
最后
恢复的DC（DC，保存索引）；
结束；
ControlState:=ControlState-[csPaintCopy]；
结束；
结束；

请注意，即使是Delphi的实现也没有为

TEdit

和

TMemo

绘制正确的主题边框：

原小组：

使用painto的结果：

---

我研究了一个较新版本的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;

程序WinControl\u painto（a控制：TWinControl；DC:HDC；X，Y：整数）；
程序DrawThemeEdge（DC:HDC；var DrawRect:TRect）；
变量
详细信息：t详细信息；
保存：整数；
开始
Save:=SaveDC（DC）；
尝试
用DrawRect do
排除CLIPRECT（直流，左+2，上+2，右-2，下-2）；
详细信息：=ThemeServices.GetElementDetails（teEditTextNormal）；
ThemeServices.DrawElement（DC、详细信息、DrawRect）；
最后
恢复的DC（DC，保存）；
结束；
充气（DrawRect，-2，-2）；
结束；
变量
一、 EdgeFlags、BorderFlags、SaveIndex:Integer；
R:TRect；
l控制：t控制；
开始
用乌头
开始
ControlState:=ControlState+[csPaintCopy]；
SaveIndex:=SaveDC（DC）；
尝试
移动窗口组织（DC、X、Y）；
IntersectClipRect（DC，0，0，宽度，高度）；
边界标志：=0；
边间隙：=0；
如果GetWindowLong（句柄，GWL_EXSTYLE）和WS_EX_CLIENTEDGE为0，则
开始
边缘凹陷：=边缘凹陷；
BorderFlags:=BF\u RECT或BF\u ADJUST
结束其他
如果GetWindowLong（句柄，GWL_样式）和WS_边框为0，则
开始
边缘层：=BDR_外部；
BorderFlags:=BF_RECT或BF_ADJUST或BF_MONO；
结束；
if（EdgeFlags=EDGE_Unken）和ThemeServices.ThemesEnabled和
而不是（（csDesigning in ComponentState））那么
开始
//绘制边框主题。
SetRect（R，0，0，宽度，高度）；
如果CSE需要ControlStyle中的命令绘制，则
牵引进料（直流，右）
其他的
开始
ControlStyle:=ControlStyle+[CSneedsOrderPaint]；
拔出饲料（DC，R）；
ControlStyle:=ControlStyle-[CSneedsOrderPaint]；
结束；
移动窗口组织（DC，右左，右上）；
交叉点（DC，0，0，右-右-左，右下-右上）；
结束
否则，如果边界标记为0，则
开始
SetRect（R，0，0，宽度，高度）；
抽屉边缘（DC、R、边缘标记、边界标记）；
移动窗口组织（DC，右左，右上）；
交叉点（DC，0，0，右-右-左，右下-右上）；
结束；
执行（WM_ERASEBKGND，DC，0）；
执行（WM_油漆，直流，0）；