Я согласен, что не должно быть проблем с сотней флажков в форме. Но ради интереса я только что написал компонент, который выполняет все рисование вручную, поэтому для каждого элемента управления есть только один дескриптор окна (то есть на восемь флажков). Мой элемент управления работает как с включенными визуальными темами, так и с отключенными темами. Он также имеет двойную буферизацию и полностью не мерцает.
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.
Пример:
(высокое разрешение)