自动调整大小的TCheckBox（如TLabel）

Question

我想创建一个复选框，可以自动调整其宽度，就像TLabel一样。

UNIT cvCheckBox;
{  It incercepts CMTextChanged where it recomputes the new Width}
INTERFACE
USES
  Winapi.Windows, Winapi.Messages, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.StdCtrls;

TYPE
 TcCheckBox = class(TCheckBox)
 private
   FAutoSize: Boolean;
   procedure AdjustBounds;
   procedure setAutoSize(b: Boolean);  reintroduce;
   procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
   procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
 protected
    procedure Loaded; override;
 public
    constructor Create(AOwner: TComponent); override;
 published
    //property Caption read GetText write SetText;
    property AutoSize: Boolean read FAutoSize write setAutoSize stored TRUE;
 end;

IMPLEMENTATION

CONST
  SysCheckWidth: Integer = 21;  // In theory this can be obtained from the "system"

constructor TcCheckBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FAutoSize:= TRUE;
end;


procedure TcCheckBox.AdjustBounds;
VAR
   DC: HDC;
   Canvas: TCanvas;
begin
  if not (csReading in ComponentState) and FAutoSize then
  begin
    // this caused the problem [solution provided by Dima] 
    if HandleAllocated then   // Deals with the missing parent during Creation
    begin
     // We need a canvas but this control has none. So we need to "produce" one.
     Canvas := TCanvas.Create;
     DC     := GetDC(Handle);
     TRY
       Canvas.Handle := DC;
       Canvas.Font   := Font;
       Width := Canvas.TextWidth(Caption) + SysCheckWidth + 4;
       Canvas.Handle := 0;
     FINALLY
       ReleaseDC(Handle, DC);
       Canvas.Free;
     END;
    end;
  end;
end;


procedure TcCheckBox.setAutoSize(b: Boolean);
begin
  if FAutoSize <> b then
  begin
    FAutoSize := b;
    if b then AdjustBounds;
  end;
end;

procedure TcCheckBox.CMTextChanged(var Message:TMessage);
begin
  Invalidate;
  AdjustBounds;
end;


procedure TcCheckBox.CMFontChanged(var Message:TMessage);
begin
  inherited;
  if AutoSize
  then AdjustBounds;
end;

procedure TcCheckBox.Loaded;
begin
  inherited Loaded;
  AdjustBounds;
end;
end.

但是我有一个问题。PageControl的非活动选项卡中放置的复选框不会自动重新计算其大小。换句话说，如果我有两个包含复选框的选项卡，则在应用程序启动时，将仅正确调整当前打开的选项卡中的复选框的大小。当我单击另一个选项卡时，该复选框将具有原始大小（设计时设置的大小）。

我确实在程序启动时设置了整个表单的字体大小（在Form Create之后，使用PostMessage（Self.Handle，MSG_LateInitialize））。

procedure TForm5.FormCreate(Sender: TObject);
begin
 PostMessage(Self.Handle, MSG_LateInitialize, 0, 0);  
end;

procedure TForm5.LateInitialize(var message: TMessage);
begin
 Font:= 22;
end;

为什么未激活的选项卡中的复选框未宣布字体已更改？

Answer 1

As I have stated in comment to the question, the problem lies in the fact that TPageControl initializes only the page that is currently selected. It means that another pages will have no valid handle. Since this, all components that are placed on them have no handle as well. This is a reason for which AdjustBounds method does not work at all.

But this bad situation can be solved with getting DeviceContext in other manner using constant HWND_DESKTOP (see Update part for details).
See the code below:

procedure TcCheckBox.AdjustBounds;
var
  DC: HDC;
  Canvas: TCanvas;
begin
  if not (csReading in ComponentState) and FAutoSize then
  begin
    // Retrieve DC for the entire screen
    DC := GetDC(HWND_DESKTOP);
    try
      // We need a canvas but this control has none. So we need to "produce" one.
      Canvas := TCanvas.Create;
      try
        Canvas.Handle := DC;
        Canvas.Font := Font;
        Width := Canvas.TextWidth(Caption) + SysCheckWidth + 4;
        Canvas.Handle := 0;
      finally
        Canvas.Free;
      end;
    finally
      ReleaseDC(HWND_DESKTOP, DC);
    end;
  end;
end;

Update
Since some useful comments have been posted, I changed the code to get rid of call to GetDesktopWindow function. Instead, code uses HWND_DESKTOP constant that being passed to GetDC function allows obtain DeviceContext for the entire screen.