Delphi OwnerDraw PageControl 自定义答案

【问题标题】：Delphi OwnerDraw PageControl customizationDelphi OwnerDraw PageControl 自定义
【发布时间】：2016-02-10 12:16:59
【问题描述】：

我有一个带有OwnerDraw PageControl 的项目。我需要按如下方式自定义它：

所以我写了以下代码：

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls;

type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  protected
    procedure CNDrawitem(var Message: TWMDrawItem); message CN_DRAWITEM;
  end;


type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    TabSheet4: TTabSheet;
    TabSheet5: TTabSheet;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure TPageControl.CNDrawItem(var Message: TWMDrawItem);
var
  Color: TColor;
  Rect: TRect;
  Rgn: HRGN;
  SaveIndex: Integer;
  Caption:string;
  Size   :TSize;
  x,y    :integer;
begin
  Color := clBlack;
  case Message.DrawItemStruct.itemID of
    0: Color := $008000FF;
    1: Color := $00FF0080;
    2: Color := $00408000;
  end;
  SetDCBrushColor(Message.DrawItemStruct.hDC, Color);

  SelectClipRgn(Message.DrawItemStruct.hDC, 0);

  Rect := Message.DrawItemStruct.rcItem;
  if Bool(Message.DrawItemStruct.itemState and ODS_SELECTED) then begin
    Inc(Rect.Left, 2);
    Dec(Rect.Right, 2);
    Dec(Rect.Bottom, 3);
  end else begin
    Dec(Rect.Left, 2);
    Dec(Rect.Top, 2);
    Inc(Rect.Right, 2);
    Inc(Rect.Bottom);
  end;
  FillRect(Message.DrawItemStruct.hDC, Rect, GetStockObject(DC_BRUSH));

  Rgn := CreateRectRgn(0, 0, 0, 0);
  SelectClipRgn(Message.DrawItemStruct.hDC, Rgn);
  DeleteObject(Rgn);

  with Message.DrawItemStruct^ do
  begin
    SaveIndex := SaveDC(hDC);
    Canvas.Lock;
    try
      Canvas.Handle:=hDC;
      Canvas.Font  :=Font;
      Canvas.Brush :=Brush;
      Caption:=Self.Tabs.Strings[ItemID];
      Size:=Canvas.TextExtent(Caption);
      x:=rcItem.Left+(rcItem.Right-rcItem.Left-Size.cx) div 2;
      y:=rcItem.Top +(rcItem.Bottom-rcItem.Top-Size.cy) div 2+1;
      if Bool(Message.DrawItemStruct.itemState and ODS_SELECTED) then dec(y);
      Canvas.TextRect(rcItem,x,y,Caption);
    finally
      Canvas.Handle := 0;
      Canvas.Unlock;
      RestoreDC(hDC, SaveIndex);
    end;
  end;
  Message.Result := 1;
  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PageControl1.Ctl3D:=False;
end;

end.

但编译后我得到如下：

如何解决问题？

我的要求如下：
1.PageControl中的3D边框应该被移除。
2. 表单背景颜色应从PageControl中移除。
3.选中Tab颜色和高度应该不同。
4. TabSheet 背景应该是可定制的。

之后我尝试了以下代码：

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls;

type
  TPageControl = class(Vcl.ComCtrls.TPageControl)
  private
    { Private procedure }
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  protected
    { protected procedure }
    procedure WndProc(var Message:TMessage); override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public procedure }

  published
    { published procedure }
  end;

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    TabSheet4: TTabSheet;
    TabSheet5: TTabSheet;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TPageControl.WndProc(var Message:TMessage);
begin
  if Message.Msg=TCM_ADJUSTRECT then
  begin
    Inherited WndProc(Message);
    if Fborder=bsNone then
    begin
      PRect(Message.LParam)^.Left:=0;
      PRect(Message.LParam)^.Right:=ClientWidth;
      PRect(Message.LParam)^.Top:=PRect(Message.LParam)^.Top-4;
      PRect(Message.LParam)^.Bottom:=ClientHeight;
    end;
  end
  else
    Inherited WndProc(Message);
end;

procedure TPageControl.CNDrawItem(var Message: TWMDrawItem);
var
  Color: TColor;
  Rect: TRect;
  Rgn: HRGN;
  SaveIndex: Integer;
  Caption:string;
  Size   :TSize;
  x,y    :integer;
begin
  Color := 0;
  case Message.DrawItemStruct.itemID of
    0: Color := $008000FF;
    1: Color := $00FF0080;
    2: Color := $00408000;
  end;
  SetDCBrushColor(Message.DrawItemStruct.hDC, Color);

  SelectClipRgn(Message.DrawItemStruct.hDC, 0);

  Rect := Message.DrawItemStruct.rcItem;
  if Bool(Message.DrawItemStruct.itemState and ODS_SELECTED) then begin
    Inc(Rect.Left, 2);
    Dec(Rect.Right, 2);
    Dec(Rect.Bottom, 3);
  end else begin
    Dec(Rect.Left, 2);
    Dec(Rect.Top, 2);
    Inc(Rect.Right, 2);
    Inc(Rect.Bottom);
  end;
  FillRect(Message.DrawItemStruct.hDC, Rect, GetStockObject(DC_BRUSH));

  Rgn := CreateRectRgn(0, 0, 0, 0);
  SelectClipRgn(Message.DrawItemStruct.hDC, Rgn);
  DeleteObject(Rgn);

  with Message.DrawItemStruct^ do
  begin
    SaveIndex := SaveDC(hDC);
    Canvas.Lock;
    try
      Canvas.Handle:=hDC;
      Canvas.Font  :=Font;
      Canvas.Brush :=Brush;
      Caption:=Self.Tabs.Strings[ItemID];
      Size:=Canvas.TextExtent(Caption);
      x:=rcItem.Left+(rcItem.Right-rcItem.Left-Size.cx) div 2;
      y:=rcItem.Top +(rcItem.Bottom-rcItem.Top-Size.cy) div 2+1;
      if Bool(Message.DrawItemStruct.itemState and ODS_SELECTED) then dec(y);
      Canvas.TextRect(rcItem,x,y,Caption);
    finally
      Canvas.Handle := 0;
      Canvas.Unlock;
      RestoreDC(hDC, SaveIndex);
    end;
  end;
  Message.Result := 1;
  inherited;
end;

procedure TPageControl.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style:=Params.Style or TCS_OWNERDRAWFIXED;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PageControl1.Ctl3D:=False;
end;

end.

但它没有编译。

【问题讨论】：

it is not compiling - 它到底在哪里失败，错误是什么？
我收到以下错误：[dcc32 Error] Unit1.pas(16): E2065 Unsatisfied forward or external declaration: 'TPageControl.WndProc'[dcc32 Error] Unit1.pas(17): E2065 Unsatisfied forward or external declaration: 'TPageControl.CreateParams'[dcc32 Fatal Error] Project1.dpr(5): F2063 Could not compile used unit 'Unit1.pas' [dcc32 致命错误] Project1.dpr(5): F2063 Could not compile used unit 'Unit1.pas'`跨度>
我收到了Undeclared identifier: 'TCM_ADJUSTRECT', Fborder and TCS_OWNERDRAWFIXED。 任何反馈都会很好:)
我也试过this，但无法编译。 同样的错误。

标签： delphi

【解决方案1】：

以防万一有人遇到这个老问题，在 Winapi.CommCtrl 中定义了 TCM_ADJUSTRECT 和 TCS_OWNERDRAWFIXED。 TPageControl 及其任何祖先都具有 Border 属性或 FBorder 成员。如果你觉得你需要一个，你应该通过从 TCustomTabControl 或 TPageControl 派生来创建一个新控件。

【讨论】：