Custom Control Creation in Delphi

Question

I used this on a form and created it like 10 times. That was ok, until I tried to pass this number. Then it started eating system resources. Is there any way I could create

Answer 1

I agree that there shouldn't be a problem with a hundred checkboxes on a form. But for fun's sake, I just wrote a component that does all drawing manually, so there is only one window handle per control (that is, per eight checkboxes). My control works both with visual themes enabled and with themes disabled. It is also double-buffered, and completely flicker-free.

unit ByteEditor;

interface

uses
  Windows, SysUtils, Classes, Messages, Controls, Graphics, Themes, UxTheme;

type
  TWinControlCracker = class(TWinControl); // because necessary method SelectNext is protected...

  TByteEditor = class(TCustomControl)
  private
    { Private declarations }
    FTextLabel: TCaption;
    FBuffer: TBitmap;
    FValue: byte;
    CheckboxRect: array[0..7] of TRect;
    LabelRect: array[0..7] of TRect;
    FSpacing: integer;
    FVerticalSpacing: integer;
    FLabelSpacing: integer;
    FLabelWidth, FLabelHeight: integer;
    FShowHex: boolean;
    FHexPrefix: string;
    FMouseHoverIndex: integer;
    FKeyboardFocusIndex: integer;
    FOnChange: TNotifyEvent;
    FManualLabelWidth: integer;
    FAutoLabelSize: boolean;
    FLabelAlignment: TAlignment;
    procedure SetTextLabel(const TextLabel: TCaption);
    procedure SetValue(const Value: byte);
    procedure SetSpacing(const Spacing: integer);
    procedure SetVerticalSpacing(const VerticalSpacing: integer);
    procedure SetLabelSpacing(const LabelSpacing: integer);
    procedure SetShowHex(const ShowHex: boolean);
    procedure SetHexPrefix(const HexPrefix: string);
    procedure SetManualLabelWidth(const ManualLabelWidth: integer);
    procedure SetAutoLabelSize(const AutoLabelSize: boolean);
    procedure SetLabelAlignment(const LabelAlignment: TAlignment);
    procedure UpdateMetrics;
  protected
    { Protected declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure WndProc(var Msg: TMessage); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
  public
    { Public declarations }
  published
    { Published declarations }
    property Color;
    property LabelAlignment: TAlignment read FLabelAlignment write SetLabelAlignment default taRightJustify;
    property AutoLabelSize: boolean read FAutoLabelSize write SetAutoLabelSize default true;
    property ManualLabelWidth: integer read FManualLabelWidth write SetManualLabelWidth default 64;
    property TextLabel: TCaption read FTextLabel write SetTextLabel;
    property Value: byte read FValue write SetValue default 0;
    property Spacing: integer read FSpacing write SetSpacing default 3;
    property VerticalSpacing: integer read FVerticalSpacing write SetVerticalSpacing default 3;
    property LabelSpacing: integer read FLabelSpacing write SetLabelSpacing default 8;
    property ShowHex: boolean read FShowHex write SetShowHex default false;
    property HexPrefix: string read FHexPrefix write SetHexPrefix;
    property TabOrder;
    property TabStop;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

implementation

const
  PowersOfTwo: array[0..7] of byte = (1, 2, 4, 8, 16, 32, 64, 128); // PowersOfTwo[n] := 2^n
  BasicCheckbox: TThemedElementDetails = (Element: teButton; Part: BP_CHECKBOX; State: CBS_UNCHECKEDNORMAL);

procedure Register;
begin
  RegisterComponents('Rejbrand 2009', [TByteEditor]);
end;

function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
  IsIntInInterval := (xmin <= x) and (x <= xmax);
end;

function PointInRect(const Point: TPoint; const Rect: TRect): boolean; inline;
begin
  PointInRect := IsIntInInterval(Point.X, Rect.Left, Rect.Right) and
                 IsIntInInterval(Point.Y, Rect.Top, Rect.Bottom);
end;

function GrowRect(const Rect: TRect): TRect;
begin
  result.Left := Rect.Left - 1;
  result.Top := Rect.Top - 1;
  result.Right := Rect.Right + 1;
  result.Bottom := Rect.Bottom + 1;
end;

{ TByteEditor }

constructor TByteEditor.Create(AOwner: TComponent);
begin
  inherited;
  FLabelAlignment := taRightJustify;
  FManualLabelWidth := 64;
  FAutoLabelSize := true;
  FTextLabel := 'Register:';
  FValue := 0;
  FSpacing := 3;
  FVerticalSpacing := 3;
  FLabelSpacing := 8;
  FMouseHoverIndex := -1;
  FKeyboardFocusIndex := 7;
  FHexPrefix := '$';
  FShowHex := false;
  FBuffer := TBitmap.Create;
end;

destructor TByteEditor.Destroy;
begin
  FBuffer.Free;
  inherited;
end;

procedure TByteEditor.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case Key of
    VK_TAB:
      if TabStop then
        begin
          if ssShift in Shift then
            if FKeyboardFocusIndex = 7 then
              TWinControlCracker(Parent).SelectNext(Self, false, true)
            else
              inc(FKeyboardFocusIndex)
          else
            if FKeyboardFocusIndex = 0 then
              TWinControlCracker(Parent).SelectNext(Self, true, true)
            else
              dec(FKeyboardFocusIndex);
          Paint;
        end;
    VK_SPACE:
      SetValue(FValue xor PowersOfTwo[FKeyboardFocusIndex]);
  end;
end;

procedure TByteEditor.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited;

end;

procedure TByteEditor.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if TabStop then SetFocus;
  FKeyboardFocusIndex := FMouseHoverIndex;
  Paint;
end;

procedure TByteEditor.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
  OldIndex: integer;
begin
  inherited;
  OldIndex := FMouseHoverIndex;
  FMouseHoverIndex := -1;
  for i := 0 to 7 do
    if PointInRect(point(X, Y), CheckboxRect[i]) then
    begin
      FMouseHoverIndex := i;
      break;
    end;
  if FMouseHoverIndex <> OldIndex then
    Paint;
end;

procedure TByteEditor.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  Paint;
  if (FMouseHoverIndex <> -1) and (Button = mbLeft) then
  begin
    SetValue(FValue xor PowersOfTwo[FMouseHoverIndex]);
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

const
  DTAlign: array[TAlignment] of cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);

procedure TByteEditor.Paint;
var
  details: TThemedElementDetails;
  i: Integer;
  TextRect: TRect;
  HexStr: string;
begin
  inherited;
  FBuffer.Canvas.Brush.Color := Color;
  FBuffer.Canvas.FillRect(ClientRect);

  TextRect := Rect(0, 0, FLabelWidth, Height);
  DrawText(FBuffer.Canvas.Handle, FTextLabel, length(FTextLabel), TextRect,
    DT_SINGLELINE or DT_VCENTER or DTAlign[FLabelAlignment] or DT_NOCLIP);

  for i := 0 to 7 do
  begin
    if ThemeServices.ThemesEnabled then
      with details do
      begin
        Element := teButton;
        Part := BP_CHECKBOX;
        if FMouseHoverIndex = i then
          if csLButtonDown in ControlState then
            if FValue and PowersOfTwo[i] <> 0 then
              State := CBS_CHECKEDPRESSED
            else
              State := CBS_UNCHECKEDPRESSED
          else
            if FValue and PowersOfTwo[i] <> 0 then
              State := CBS_CHECKEDHOT
            else
              State := CBS_UNCHECKEDHOT
        else
          if FValue and PowersOfTwo[i] <> 0 then
            State := CBS_CHECKEDNORMAL
          else
            State := CBS_UNCHECKEDNORMAL;
        ThemeServices.DrawElement(FBuffer.Canvas.Handle, details, CheckboxRect[i]);
      end
    else
    begin
      if FMouseHoverIndex = i then
        if csLButtonDown in ControlState then
          if FValue and PowersOfTwo[i] <> 0 then
            DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_PUSHED)
          else
            DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_PUSHED)
        else
          if FValue and PowersOfTwo[i] <> 0 then
            DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_HOT)
          else
            DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_HOT)
      else
        if FValue and PowersOfTwo[i] <> 0 then
          DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED)
        else
          DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK)
    end;
    TextRect := LabelRect[i];
    DrawText(FBuffer.Canvas.Handle, IntToStr(i), 1, TextRect, DT_SINGLELINE or DT_TOP or DT_CENTER or DT_NOCLIP);
  end;

  if Focused then
    DrawFocusRect(FBuffer.Canvas.Handle, GrowRect(CheckboxRect[FKeyboardFocusIndex]));

  if FShowHex then
  begin
    TextRect.Left := CheckboxRect[7].Left;
    TextRect.Right := CheckboxRect[0].Right;
    TextRect.Top := CheckboxRect[7].Bottom + FVerticalSpacing;
    TextRect.Bottom := TextRect.Top + FLabelHeight;
    HexStr := 'Value = ' + IntToStr(FValue) + ' (' + FHexPrefix + IntToHex(FValue, 2) + ')';
    DrawText(FBuffer.Canvas.Handle, HexStr, length(HexStr), TextRect,
      DT_SINGLELINE or DT_CENTER or DT_NOCLIP);
  end;

  BitBlt(Canvas.Handle, 0, 0, Width, Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY);


end;

procedure TByteEditor.SetShowHex(const ShowHex: boolean);
begin
  if ShowHex <> FShowHex then
  begin
    FShowHex := ShowHex;
    Paint;
  end;
end;

procedure TByteEditor.SetSpacing(const Spacing: integer);
begin
  if Spacing <> FSpacing then
  begin
    FSpacing := Spacing;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TByteEditor.SetVerticalSpacing(const VerticalSpacing: integer);
begin
  if VerticalSpacing <> FVerticalSpacing then
  begin
    FVerticalSpacing := VerticalSpacing;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TByteEditor.SetAutoLabelSize(const AutoLabelSize: boolean);
begin
  if FAutoLabelSize <> AutoLabelSize then
  begin
    FAutoLabelSize := AutoLabelSize;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TByteEditor.SetHexPrefix(const HexPrefix: string);
begin
  if not SameStr(FHexPrefix, HexPrefix) then
  begin
    FHexPrefix := HexPrefix;
    Paint;
  end;
end;

procedure TByteEditor.SetLabelAlignment(const LabelAlignment: TAlignment);
begin
  if FLabelAlignment <> LabelAlignment then
  begin
    FLabelAlignment := LabelAlignment;
    Paint;
  end;
end;

procedure TByteEditor.SetLabelSpacing(const LabelSpacing: integer);
begin
  if LabelSpacing <> FLabelSpacing then
  begin
    FLabelSpacing := LabelSpacing;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TByteEditor.SetManualLabelWidth(const ManualLabelWidth: integer);
begin
  if FManualLabelWidth <> ManualLabelWidth then
  begin
    FManualLabelWidth := ManualLabelWidth;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TByteEditor.SetTextLabel(const TextLabel: TCaption);
begin
  if not SameStr(TextLabel, FTextLabel) then
  begin
    FTextLabel := TextLabel;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TByteEditor.SetValue(const Value: byte);
begin
  if Value <> FValue then
  begin
    FValue := Value;
    Paint;
  end;
end;

procedure TByteEditor.WndProc(var Msg: TMessage);
begin
  inherited;
  case Msg.Msg of
    WM_GETDLGCODE:
      Msg.Result := Msg.Result or DLGC_WANTTAB or DLGC_WANTARROWS or DLGC_WANTALLKEYS;
    WM_ERASEBKGND:
      Msg.Result := 1;
    WM_SIZE:
      begin
        UpdateMetrics;
        Paint;
      end;
    WM_SETFOCUS, WM_KILLFOCUS:
      Paint;
  end;
end;

procedure TByteEditor.UpdateMetrics;
var
  CheckboxWidth, CheckboxHeight: integer;
  i: Integer;
begin
  FBuffer.SetSize(Width, Height);
  FBuffer.Canvas.Font.Assign(Font);
  with FBuffer.Canvas.TextExtent(FTextLabel) do
  begin
    if FAutoLabeLSize then
      FLabelWidth := cx
    else
      FLabelWidth := FManualLabelWidth;
    FLabelHeight := cy;
  end;
  CheckboxWidth := GetSystemMetrics(SM_CXMENUCHECK);
  CheckboxHeight := GetSystemMetrics(SM_CYMENUCHECK);
  for i := 0 to 7 do
  begin
    with CheckboxRect[i] do
    begin
      Left := (FLabelWidth + FLabelSpacing) + (7-i) * (CheckboxWidth + FSpacing);
      Right := Left + CheckboxWidth;
      Top := (Height - (CheckboxHeight)) div 2;
      Bottom := Top + CheckboxHeight;
    end;
    LabelRect[i].Left := CheckboxRect[i].Left;
    LabelRect[i].Right := CheckboxRect[i].Right;
    LabelRect[i].Top := CheckboxRect[i].Top - FLabelHeight - FVerticalSpacing;
    LabelRect[i].Bottom := CheckboxRect[i].Top;
  end;
  Width := (FLabelWidth + FLabelSpacing) + 8 * (CheckboxWidth + FSpacing);
end;


end.

Example:

(High-Res)