Delphi OwnerDraw PageControl定制

Question

我有一个和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.

但在编译之后，我得到的结果如下：

​

如何解决这个问题？

我的要求如下：

应该从PageControl.

• Form中删除different.

• TabSheet

1. 3D边框的背景色，应该从different.
2. TabSheet中删除Tab的颜色和高度，应该可以自定义背景。

在那之后，我尝试了以下代码：

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.  

但是它不是编译的。

Answer 1

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