自动调整 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 的非活动选项卡中的复选框不会自动重新计算它们的大小。 换句话说，如果我有两个包含复选框的选项卡，在应用程序启动时，只有当前打开的选项卡中的复选框会正确调整大小。 当我单击另一个选项卡时，复选框将具有原始大小（设计时设置的大小）。

我确实在程序启动时设置了整个表单的字体大小（在表单创建之后，使用 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

正如我在对该问题的评论中所述，问题在于TPageControl仅初始化当前选择的页面。 这意味着另一个页面将没有有效的句柄。 因此，放置在其上的所有组件也没有手柄。 这就是AdjustBounds方法根本不起作用的原因。

但是这种糟糕的情况可以通过使用常量HWND_DESKTOP以其他方式获取DeviceContext来解决（有关详细信息，请参阅更新部分）。
请参阅下面的代码：

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;

更新
由于已经发布了一些有用的评论，我更改了代码以摆脱对GetDesktopWindow函数的调用。 相反，代码使用传递给GetDC函数的HWND_DESKTOP常量允许获取整个屏幕的DeviceContext 。

Answer 2

做这样的事情

procedure TForm1.Button1Click(Sender: TObject);
var
  i1 : integer ;
begin
  for i1 := 0 to Form1.componentcount-1 do
   if Form1.components[i1] is TcCheckBox then
     TcCheckBox (Form1.components[i1]).Font.Size := 30 ;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
acCheckBox := TcCheckBox.Create(self) ;
acCheckBox.top := 20 ;
acCheckBox.Caption := 'hello world' ;
acCheckBox.Parent := TabSheet1 ;
acCheckBox := TcCheckBox.Create(self) ;
acCheckBox.top := 20 ;
acCheckBox.Caption := 'hello world' ;
acCheckBox.Parent := TabSheet2 ;
end;