Создание пользовательских элементов управления в Delphi - PullRequest
3 голосов
/ 10 октября 2010

Я использовал это в форме и создавал ее 10 раз, это было нормально, пока я не попытался передать это число, он начал использовать системные ресурсы, есть ли способ создать такой компонент? это для проекта симулятора, 8 бит, необходимых для указания значения регистра в двоичном виде

alt text

любая помощь, комментарии, идеи действительно ценятся. ти.

Ответы [ 3 ]

20 голосов
/ 10 октября 2010

Мне было немного скучно, и я хотел поиграть с моим новым Delphi XE, поэтому я сделал для вас компонент. Это должно работать в старых Delphi, просто отлично.

BitEdit demo app

Вы можете скачать его здесь: BitEditSample.zip

Как это работает?

  • Он наследуется от customcontrol, поэтому вы можете сфокусировать компонент.
  • Содержит массив меток и флажков.
  • Номер бита хранится в свойстве «tag» каждого флажка
  • Каждый флажок получает обработчик onchange, который читает тег, чтобы увидеть, каким битом нужно манипулировать.

Как его использовать

  • Имеет свойство «значение». Если вы измените его, флажки будут обновлены.
  • Если вы установите флажки, значение изменится.
  • Установите свойство "заголовок", чтобы изменить текст с надписью "Зарегистрировать X:"
  • Вы можете создать обработчик события "onchange", чтобы при изменении значения (например, из-за щелчка мышью) вы получали уведомление.

zip-файл содержит компонент, пакет и пример приложения (включая скомпилированный exe, так что вы можете быстро его опробовать).

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.

Ресурсы

Полагаю, проблема, с которой столкнулся OP, - это цикл обратной связи, в котором два обработчика событий вызывают друг друга.

Другие ресурсы, кажется, не увеличиваются необычным образом при использовании более битовых редакторов. Я протестировал его с приложением со многими экземплярами компонента bit edit:

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 
17 голосов
/ 11 октября 2010

Я согласен, что не должно быть проблем с сотней флажков в форме. Но ради интереса я только что написал компонент, который выполняет все рисование вручную, поэтому для каждого элемента управления есть только один дескриптор окна (то есть на восемь флажков). Мой элемент управления работает как с включенными визуальными темами, так и с отключенными темами. Он также имеет двойную буферизацию и полностью не мерцает.

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.

Пример:

Пример управления байтовым редактором
(высокое разрешение)

2 голосов
/ 10 октября 2010

У вас есть следующие варианты, в порядке сложности:

  1. Создание фрейма и его повторное использование
  2. Создание составного элемента управления (возможно, с использованием панели, надписей и флажков).Каждый элемент управления будет обрабатывать свое собственное взаимодействие с клавиатурой и мышью.
  3. Создать целый новый элемент управления - все элементы отрисовываются с использованием соответствующих API, а все взаимодействие с клавиатурой / мышью обрабатывается кодом элемента управления.
...