发表新帖
发表新帖

Custom Control Creation in Delphi

前端 未结
关注
3 542
醉梦人生
醉梦人生 2020-12-15 14:36

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

相关标签:
3条回答
  • 囚心锁ツ
    2020-12-15 14:51

    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)

    0 讨论(0)
  • 滥情空心
    2020-12-15 14:56

    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
    0 讨论(0)
  • 渐次进展
    2020-12-15 14:56

    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.
    0 讨论(0)
 看不清?
提交回复
热议问题