Custom Control Creation in Delphi
Asked Answered
T

3

4

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 a component like this? It is for a Simulator project, 8bits needed to indicate the value of the register in binary.

alt text

any help, comments, ideas are really appreciated. ty.

Theodor answered 10/10, 2010 at 15:10 Comment(2)
There's absolutely nothing wrong with the picture that you provided. Whatever code may be behind it, is another matter enirely. But I can only speak for what you've provided.Mayamayakovski
like have it to drag and drop anytime, i wont have to dynmaically create it each time i need it, cause ill need like 50 or soTheodor
P
20

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:

Byte Editor Control Example
(High-Res)

Phosphoprotein answered 10/10, 2010 at 20:27 Comment(17)
@Sertac: Also, I love to build GUIs and dig into Windows API, so it was also a good training exercise.Phosphoprotein
@Andreas - Yep, it figures.. I recall your highly disputed answer about 3rd party components. :)Fortson
its amazing man, small thing, TabStop property not working correctly, u can still use it on the Checkboxes thanks alot, now i got some code to read :D and use :D, and some ppl to credit :DTheodor
with CheckboxRect[i] do begin Top := ((Height - (CheckboxHeight)) div 2) + ((CheckboxHeight + VerticalSpacing) div 2); i think this line will align the caption in the middle of the Checkboxes and Title, but i dunno if this is the best method or notTheodor
@killercode: Yes, I just though it looked better if the numbers were above the label and checkboxes, that share the same line. But you can do as you like.Phosphoprotein
ok, ty can u check the TabStop thing? tab stop is not working for the control when its set to false correctly, but when u click on any check box, it works for the checkboxes no matter what pixhost.org/show/1550/4147431_imge.png (Windows XP)Theodor
@killercode: Now the control will not get focus when clicked if TabStop is false.Phosphoprotein
THANKS ALOT XD XD XD XD MAN, YOU RULE :DTheodor
im deeply sorry, can u tell me how can i add a panel control to it to be abel to display the hex value?, ive been trying to since yesterday and i got totally lostTheodor
killercode, you should really start to accept answers if you find them useful - that's how StackOverflow should work. And it's a way to say thank you to the one who helped you best.Garry
@killercode: Now I added this feature. Set ShowHex to true. You might also want to change the HexPrefix (for instance, to '0x').Phosphoprotein
ooooooooh, so thats how stackoverflow works, sorry, i didnt know, so all i have to do is to Click that Tick icon under the answer right?Theodor
im sorry, i didnt wanna abuse u anymore, but i cant seem to be abel to do it, im new to the world of API and stuff, here is y i asked the first time for a TPanel control, so i can do this and i wont have to ask u to redesign it, sorry :(, pixhost.org/show/1423/4154060_look.png, im sure u can see the diffrence, the ones on the left are aligned since its a fixed size TPanel and it looks good, i can understand if u dont wanna do it, i know that its my fault and mine only, thanks for everything :), ill keep tryingTheodor
@killercode: OK, now I see what you mean. I have updated the component. To align the controls, set AutoLabelWidth to false, and then set ManualLabelWidth to the width you want to reserve for the labels. If you just set the same ManualLabelWidth of all controls, they will align just fine.Phosphoprotein
@killercode: Now I also added the property LabelAlignment, so you can choose if you want to left och right align your label column.Phosphoprotein
hmmmmm, lets say its not perfect.....ITS HEL* MORE THAN PERFECT, THANKS ALOT MAN, i hope there was anything i can do for u incharge :) thanks again, u saved my whole world this timeTheodor
What happens when Theme services are not available? Oh I see. You have code for both. Aren't you a clever fellow.Sumy
I
22

I was slightly bored, and I wanted to play with my new Delphi XE, so I've made a component for you. It should work in older Delphi's just fine.

BitEdit demo app

You can download it here: BitEditSample.zip

How does it work?

  • It inherits from customcontrol, so you can focus the component.
  • It contains an array of labels and checkboxes.
  • The bit number is stored in the "tag" property of each checkbox
  • Each checkbox gets an onchange handler that reads the tag, to see which bit needs to be manipulated.

How to use it

  • It has a property "value". If you change it, the checkboxes will update.
  • If you click the checkboxes, the value will change.
  • Set the property "caption" to change the text that says "Register X:"
  • You can create an "onchange" event handler, so that when the value changes (because of a mouseclick for example), you'll be notified.

The zipfile contains a component, a package, and a sample application (including a compiled exe, so you can try it out quickly).

unit BitEdit;

interface

uses
  SysUtils, Classes, Controls, StdCtrls, ExtCtrls;

type
  TBitEdit = class(TCustomControl)
  private
    FValue         : Byte; // store the byte value internally
    FBitLabels     : Array[0..7] of TLabel; // the 7 6 5 4 3 2 1 0 labels
    FBitCheckboxes : Array[0..7] of TCheckBox;
    FCaptionLabel  : TLabel;
    FOnChange      : TNotifyEvent;
    function GetValue: byte;
    procedure SetValue(const aValue: byte);
    procedure SetCaption(const aValue: TCaption);
    procedure SetOnChange(const aValue: TNotifyEvent);
    function GetCaption: TCaption;
    { Private declarations }
  protected
    { Protected declarations }
    procedure DoBitCheckboxClick(Sender:TObject);
    procedure UpdateGUI;
    procedure DoOnChange;
  public
    constructor Create(AOwner: TComponent); override;
    { Public declarations }
  published
    property Value:byte read GetValue write SetValue;
    property Caption:TCaption read GetCaption write SetCaption;
    property OnChange:TNotifyEvent read FOnChange write SetOnChange;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TBitEdit]);
end;

{ TBitEdit }

constructor TBitEdit.Create(AOwner: TComponent);
var
  I:Integer;
begin
  inherited;
  Width := 193;
  Height := 33;

  FCaptionLabel := TLabel.Create(self);
  FCaptionLabel.Left := 0;
  FCaptionLabel.Top  := 10;
  FCaptionLabel.Caption := 'Register X :';
  FCaptionLabel.Width := 60;
  FCaptionLabel.Parent := self;
  FCaptionLabel.Show;


  for I := 0 to 7 do
  begin
    FBitCheckboxes[I] := TCheckBox.Create(self);
    FBitCheckboxes[I].Parent := self;
    FBitCheckboxes[I].Left   := 5 + FCaptionLabel.Width + (16 * I);
    FBitCheckboxes[I].Top    := 14;
    FBitCheckboxes[I].Caption := '';
    FBitCheckboxes[I].Tag  := 7-I;
    FBitCheckboxes[I].Hint := 'bit ' + IntToStr(FBitCheckboxes[I].Tag);
    FBitCheckboxes[I].OnClick := DoBitCheckboxClick;
  end;

  for I := 0 to 7 do
  begin
    FBitLabels[I] := TLabel.Create(Self);
    FBitLabels[I].Parent := self;
    FBitLabels[I].Left   := 8 + FCaptionLabel.Width + (16 * I);
    FBitLabels[I].Top    := 0;
    FBitLabels[I].Caption := '';
    FBitLabels[I].Tag  := 7-I;
    FBitLabels[I].Hint := 'bit ' + IntToStr(FBitLabels[I].Tag);
    FBitLabels[I].Caption := IntToStr(FBitLabels[I].Tag);
    FBitLabels[I].OnClick := DoBitCheckboxClick;
  end;


end;

procedure TBitEdit.DoBitCheckboxClick(Sender: TObject);
var
  LCheckbox:TCheckbox;
  FOldValue:Byte;
begin
  if not (Sender is TCheckBox) then
    Exit;

  FOldValue := FValue;
  LCheckbox := Sender as TCheckbox;
  FValue := FValue XOR (1 shl LCheckbox.Tag);

  if FOldValue <> FValue then
    DoOnChange;
end;

procedure TBitEdit.DoOnChange;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

function TBitEdit.GetCaption: TCaption;
begin
  Result := FCaptionLabel.Caption;
end;

function TBitEdit.GetValue: byte;
begin
  Result := FValue;
end;

procedure TBitEdit.SetCaption(const aValue: TCaption);
begin
  FCaptionLabel.Caption := aValue;
end;

procedure TBitEdit.SetOnChange(const aValue: TNotifyEvent);
begin
  FOnChange := aValue;
end;

procedure TBitEdit.SetValue(const aValue: byte);
begin
  if aValue=FValue then
    Exit;

  FValue := aValue;
  DoOnChange;
  UpdateGUI;
end;

procedure TBitEdit.UpdateGUI;
var
  I:Integer;
begin
  for I := 0 to 7 do
    FBitCheckboxes[I].Checked := FValue shr FBitCheckboxes[I].Tag mod 2 = 1;
end;

end.

Resources

I guess the problem that the OP was facing is a feedback loop, where two event handlers call each other.

Other resources don't seem to increase in an unusual way when using more bit editors. I've tested it with an application with many instances of the bit edit component:

Many

             [MANY]      |     [1]
-------------------------+--------------
#Handles                 |   
User       :   314       |          35
GDI        :    57       |          57
System     :   385       |         385
#Memory                  |
Physical   : 8264K       |       7740K
Virtual    : 3500K       |       3482K
#CPU                     | 
Kernel time: 0:00:00.468 |  0:00:00.125
User time  : 0:00:00.109 |  0:00:00.062 
Irritability answered 10/10, 2010 at 17:23 Comment(7)
So, how's resource usage when there are 10 or more of these controls? That's what prompted the question. Does this answer do anything about it?Geez
@Rob: true, true. I've added an extra paragraph about resources.Irritability
the next time you're slightly bored, I'd love to throw some work at you (at the same rate you've used here offcourse).Sigil
OMG!!!!!!!!! man, ur AMAZING xD, thanks alot, like 10,000 Times :D u saved my dayTheodor
Aren't we supposed to only inherit from "custom"? Forexample TCustomLabel instead of TLabel?Hipster
@Rigel: Indeed, that's why I inherit from TCustomControl instead of TControl. Note that the labels are not inherited themselves.Irritability
@WoutervanNifterick - oh... of course... you are right!Hipster
P
20

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:

Byte Editor Control Example
(High-Res)

Phosphoprotein answered 10/10, 2010 at 20:27 Comment(17)
@Sertac: Also, I love to build GUIs and dig into Windows API, so it was also a good training exercise.Phosphoprotein
@Andreas - Yep, it figures.. I recall your highly disputed answer about 3rd party components. :)Fortson
its amazing man, small thing, TabStop property not working correctly, u can still use it on the Checkboxes thanks alot, now i got some code to read :D and use :D, and some ppl to credit :DTheodor
with CheckboxRect[i] do begin Top := ((Height - (CheckboxHeight)) div 2) + ((CheckboxHeight + VerticalSpacing) div 2); i think this line will align the caption in the middle of the Checkboxes and Title, but i dunno if this is the best method or notTheodor
@killercode: Yes, I just though it looked better if the numbers were above the label and checkboxes, that share the same line. But you can do as you like.Phosphoprotein
ok, ty can u check the TabStop thing? tab stop is not working for the control when its set to false correctly, but when u click on any check box, it works for the checkboxes no matter what pixhost.org/show/1550/4147431_imge.png (Windows XP)Theodor
@killercode: Now the control will not get focus when clicked if TabStop is false.Phosphoprotein
THANKS ALOT XD XD XD XD MAN, YOU RULE :DTheodor
im deeply sorry, can u tell me how can i add a panel control to it to be abel to display the hex value?, ive been trying to since yesterday and i got totally lostTheodor
killercode, you should really start to accept answers if you find them useful - that's how StackOverflow should work. And it's a way to say thank you to the one who helped you best.Garry
@killercode: Now I added this feature. Set ShowHex to true. You might also want to change the HexPrefix (for instance, to '0x').Phosphoprotein
ooooooooh, so thats how stackoverflow works, sorry, i didnt know, so all i have to do is to Click that Tick icon under the answer right?Theodor
im sorry, i didnt wanna abuse u anymore, but i cant seem to be abel to do it, im new to the world of API and stuff, here is y i asked the first time for a TPanel control, so i can do this and i wont have to ask u to redesign it, sorry :(, pixhost.org/show/1423/4154060_look.png, im sure u can see the diffrence, the ones on the left are aligned since its a fixed size TPanel and it looks good, i can understand if u dont wanna do it, i know that its my fault and mine only, thanks for everything :), ill keep tryingTheodor
@killercode: OK, now I see what you mean. I have updated the component. To align the controls, set AutoLabelWidth to false, and then set ManualLabelWidth to the width you want to reserve for the labels. If you just set the same ManualLabelWidth of all controls, they will align just fine.Phosphoprotein
@killercode: Now I also added the property LabelAlignment, so you can choose if you want to left och right align your label column.Phosphoprotein
hmmmmm, lets say its not perfect.....ITS HEL* MORE THAN PERFECT, THANKS ALOT MAN, i hope there was anything i can do for u incharge :) thanks again, u saved my whole world this timeTheodor
What happens when Theme services are not available? Oh I see. You have code for both. Aren't you a clever fellow.Sumy
G
2

You have these options, in order of difficulty:

  1. Create a frame, and reuse it
  2. Create a compound control (using maybe a panel, labels and checkboxes). Each control will handle its own keyboard/mouse interaction.
  3. Create a whole new control - all elements are drawn using the proper APIs and all keyboard/mouse interaction is handled by the control code.
Garry answered 10/10, 2010 at 17:1 Comment(2)
If resource usage is an issue, then only option 3 will be any help.Geez
@Rob Kennedy: And I just implemented option 3.Phosphoprotein

© 2022 - 2024 — McMap. All rights reserved.