mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 18:43:51 +00:00
397 lines
10 KiB
ObjectPascal
397 lines
10 KiB
ObjectPascal
{
|
||
Copyright (C)
|
||
2026 - Uladzimir Karpenka, EW8BAK
|
||
|
||
This program is free software; you can redistribute it and/or
|
||
modify it under the terms of the GNU General Public License
|
||
as published by the Free Software Foundation; either version 2
|
||
of the License, or (at your option) any later version.
|
||
|
||
This program is distributed in the hope that it will be useful,
|
||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
GNU General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with this program; if not, write to the Free Software
|
||
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
}
|
||
|
||
unit FlatListBox;
|
||
|
||
{ Custom list box with canvas rendering.
|
||
Use instead of TListBox where native widgetset styling is undesirable. }
|
||
|
||
{$mode objfpc}{$H+}
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, Controls, Graphics, Forms, LCLType, LMessages, Types,
|
||
Math, AppTheme, DpiUtils;
|
||
|
||
type
|
||
TFlatListBox = class(TCustomControl)
|
||
private
|
||
FItems: TStringList;
|
||
FItemIndex: Integer;
|
||
FHotIndex: Integer;
|
||
FTopIndex: Integer;
|
||
FMouseDownIndex: Integer;
|
||
FClrOuterBG: TColor;
|
||
FClrBG: TColor;
|
||
FClrBGHot: TColor;
|
||
FClrBorder: TColor;
|
||
FClrText: TColor;
|
||
FClrTextDim: TColor;
|
||
FClrSelBG: TColor;
|
||
FClrSelText: TColor;
|
||
FClrScroll: TColor;
|
||
function ItemHeight: Integer;
|
||
function VisibleCount: Integer;
|
||
function ItemAt(Y: Integer): Integer;
|
||
procedure ItemsChanged(Sender: TObject);
|
||
procedure SetItemIndex(V: Integer);
|
||
procedure SetTopIndex(V: Integer);
|
||
procedure EnsureItemVisible(Idx: Integer);
|
||
procedure CMTextChanged(var Msg: TLMessage); message CM_TEXTCHANGED;
|
||
protected
|
||
procedure Paint; override;
|
||
procedure MouseEnter; override;
|
||
procedure MouseLeave; override;
|
||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||
X, Y: Integer); override;
|
||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||
X, Y: Integer); override;
|
||
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
||
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
|
||
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
|
||
public
|
||
constructor Create(AOwner: TComponent); override;
|
||
destructor Destroy; override;
|
||
procedure SetAppTheme(const T: TAppTheme);
|
||
|
||
property Items: TStringList read FItems;
|
||
property ItemIndex: Integer read FItemIndex write SetItemIndex;
|
||
property TopIndex: Integer read FTopIndex write SetTopIndex;
|
||
property Align;
|
||
property Anchors;
|
||
property Enabled;
|
||
property Font;
|
||
property ParentShowHint;
|
||
property PopupMenu;
|
||
property ShowHint;
|
||
property TabOrder;
|
||
property TabStop;
|
||
property Tag;
|
||
property Visible;
|
||
property OnClick;
|
||
property OnDblClick;
|
||
// Клавиатура: собственный KeyDown обрабатывает стрелки/PgUp/Home, а
|
||
// необработанные клавиши (Enter и прочее) достаются владельцу через
|
||
// inherited — поэтому событие имеет смысл публиковать.
|
||
property OnKeyDown;
|
||
end;
|
||
|
||
implementation
|
||
|
||
const
|
||
BASE_ITEM_H = 22;
|
||
BASE_PAD_X = 8;
|
||
BASE_SCROLL_W = 3;
|
||
|
||
constructor TFlatListBox.Create(AOwner: TComponent);
|
||
begin
|
||
inherited Create(AOwner);
|
||
ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents, csDoubleClicks];
|
||
FItems := TStringList.Create;
|
||
FItems.OnChange := @ItemsChanged;
|
||
FItemIndex := -1;
|
||
FHotIndex := -1;
|
||
FTopIndex := 0;
|
||
FMouseDownIndex := -1;
|
||
Width := 180;
|
||
Height := 140;
|
||
TabStop := True;
|
||
Cursor := crDefault;
|
||
|
||
Font.Size := 8;
|
||
|
||
FClrOuterBG := TColor($00181818);
|
||
FClrBG := TColor($00101010);
|
||
FClrBGHot := TColor($000C3010);
|
||
FClrBorder := TColor($00303030);
|
||
FClrText := TColor($00CCCCCC);
|
||
FClrTextDim := TColor($00666666);
|
||
FClrSelBG := TColor($00183618);
|
||
FClrSelText := TColor($0000FF88);
|
||
FClrScroll := TColor($00387838);
|
||
end;
|
||
|
||
destructor TFlatListBox.Destroy;
|
||
begin
|
||
FItems.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TFlatListBox.ItemHeight: Integer;
|
||
begin
|
||
Canvas.Font.Assign(Font);
|
||
Result := DpiScale(BASE_ITEM_H);
|
||
if Result < Canvas.TextHeight('Ag') + DpiScale(7) then
|
||
Result := Canvas.TextHeight('Ag') + DpiScale(7);
|
||
end;
|
||
|
||
function TFlatListBox.VisibleCount: Integer;
|
||
begin
|
||
Result := Max(1, (Height - DpiScale(2)) div ItemHeight);
|
||
end;
|
||
|
||
function TFlatListBox.ItemAt(Y: Integer): Integer;
|
||
begin
|
||
Result := FTopIndex + (Y - DpiScale(1)) div ItemHeight;
|
||
if (Result < 0) or (Result >= FItems.Count) then
|
||
Result := -1;
|
||
end;
|
||
|
||
procedure TFlatListBox.SetAppTheme(const T: TAppTheme);
|
||
begin
|
||
FClrOuterBG := T.Panel;
|
||
FClrBG := T.BG;
|
||
FClrBGHot := T.BtnActive;
|
||
FClrBorder := T.Border;
|
||
FClrText := T.Text;
|
||
FClrTextDim := T.TextDim;
|
||
FClrSelBG := T.SliderTrackFill;
|
||
FClrSelText := T.BtnTextActive;
|
||
FClrScroll := T.BtnBorderActive;
|
||
Font.Color := T.Text;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.ItemsChanged(Sender: TObject);
|
||
begin
|
||
if FItems.Count = 0 then
|
||
FItemIndex := -1
|
||
else if FItemIndex >= FItems.Count then
|
||
FItemIndex := FItems.Count - 1;
|
||
if FHotIndex >= FItems.Count then
|
||
FHotIndex := -1;
|
||
SetTopIndex(FTopIndex);
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.SetItemIndex(V: Integer);
|
||
begin
|
||
V := EnsureRange(V, -1, FItems.Count - 1);
|
||
if FItemIndex = V then
|
||
begin
|
||
EnsureItemVisible(FItemIndex);
|
||
Exit;
|
||
end;
|
||
FItemIndex := V;
|
||
EnsureItemVisible(FItemIndex);
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.SetTopIndex(V: Integer);
|
||
begin
|
||
V := EnsureRange(V, 0, Max(0, FItems.Count - VisibleCount));
|
||
if FTopIndex = V then Exit;
|
||
FTopIndex := V;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.EnsureItemVisible(Idx: Integer);
|
||
var
|
||
VC: Integer;
|
||
begin
|
||
if Idx < 0 then Exit;
|
||
VC := VisibleCount;
|
||
if Idx < FTopIndex then
|
||
SetTopIndex(Idx)
|
||
else if Idx >= FTopIndex + VC then
|
||
SetTopIndex(Idx - VC + 1);
|
||
end;
|
||
|
||
procedure TFlatListBox.CMTextChanged(var Msg: TLMessage);
|
||
begin
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.Paint;
|
||
var
|
||
i, ItemIdx, IH, Y, TextY, Pad, ScrollW, ThumbTop, ThumbH: Integer;
|
||
R, TextR: TRect;
|
||
begin
|
||
Canvas.Brush.Color := FClrOuterBG;
|
||
Canvas.Brush.Style := bsSolid;
|
||
Canvas.Pen.Style := psClear;
|
||
Canvas.FillRect(ClientRect);
|
||
|
||
Canvas.Brush.Color := FClrBG;
|
||
Canvas.Brush.Style := bsSolid;
|
||
Canvas.Pen.Color := FClrBorder;
|
||
Canvas.Pen.Style := psSolid;
|
||
Canvas.Pen.Width := 1;
|
||
Canvas.Rectangle(0, 0, Width, Height);
|
||
|
||
Canvas.Font.Assign(Font);
|
||
IH := ItemHeight;
|
||
Pad := DpiScale(BASE_PAD_X);
|
||
ScrollW := DpiScale(BASE_SCROLL_W);
|
||
for i := 0 to VisibleCount - 1 do
|
||
begin
|
||
ItemIdx := FTopIndex + i;
|
||
if ItemIdx >= FItems.Count then Break;
|
||
Y := DpiScale(1) + i * IH;
|
||
R := Rect(DpiScale(1), Y, Width - DpiScale(1), Y + IH);
|
||
if ItemIdx = FItemIndex then
|
||
begin
|
||
Canvas.Brush.Color := FClrSelBG;
|
||
Canvas.Font.Color := FClrSelText;
|
||
end
|
||
else if (ItemIdx = FHotIndex) and Enabled then
|
||
begin
|
||
Canvas.Brush.Color := FClrBGHot;
|
||
Canvas.Font.Color := FClrText;
|
||
end
|
||
else
|
||
begin
|
||
Canvas.Brush.Color := FClrBG;
|
||
if Enabled then
|
||
Canvas.Font.Color := FClrText
|
||
else
|
||
Canvas.Font.Color := FClrTextDim;
|
||
end;
|
||
Canvas.Pen.Style := psClear;
|
||
Canvas.Brush.Style := bsSolid;
|
||
Canvas.FillRect(R);
|
||
Canvas.Brush.Style := bsClear;
|
||
TextY := Y + (IH - Canvas.TextHeight('Ag')) div 2;
|
||
TextR := Rect(Pad, Y, Width - Pad - ScrollW, Y + IH);
|
||
Canvas.TextRect(TextR, TextR.Left, TextY, FItems[ItemIdx]);
|
||
end;
|
||
|
||
if FItems.Count > VisibleCount then
|
||
begin
|
||
ThumbH := Max(DpiScale(16), MulDiv(Height - DpiScale(4), VisibleCount, FItems.Count));
|
||
ThumbTop := DpiScale(2) + MulDiv(Height - DpiScale(4) - ThumbH,
|
||
FTopIndex, Max(1, FItems.Count - VisibleCount));
|
||
Canvas.Brush.Color := FClrScroll;
|
||
Canvas.Brush.Style := bsSolid;
|
||
Canvas.Pen.Style := psClear;
|
||
Canvas.FillRect(Rect(Width - DpiScale(5), ThumbTop, Width - DpiScale(2), ThumbTop + ThumbH));
|
||
end;
|
||
end;
|
||
|
||
procedure TFlatListBox.MouseEnter;
|
||
begin
|
||
inherited;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.MouseLeave;
|
||
begin
|
||
inherited;
|
||
FHotIndex := -1;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||
X, Y: Integer);
|
||
begin
|
||
inherited;
|
||
if (Button <> mbLeft) or not Enabled then Exit;
|
||
SetFocus;
|
||
FMouseDownIndex := ItemAt(Y);
|
||
if FMouseDownIndex >= 0 then
|
||
SetItemIndex(FMouseDownIndex);
|
||
end;
|
||
|
||
procedure TFlatListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
inherited;
|
||
if PtInRect(ClientRect, Point(X, Y)) then
|
||
Idx := ItemAt(Y)
|
||
else
|
||
Idx := -1;
|
||
if FHotIndex = Idx then Exit;
|
||
FHotIndex := Idx;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TFlatListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||
X, Y: Integer);
|
||
begin
|
||
inherited;
|
||
if Button <> mbLeft then Exit;
|
||
FMouseDownIndex := -1;
|
||
end;
|
||
|
||
procedure TFlatListBox.KeyDown(var Key: Word; Shift: TShiftState);
|
||
var
|
||
OldIndex: Integer;
|
||
begin
|
||
inherited;
|
||
if not Enabled then Exit;
|
||
OldIndex := FItemIndex;
|
||
case Key of
|
||
VK_UP:
|
||
begin
|
||
if FItems.Count > 0 then
|
||
SetItemIndex(EnsureRange(FItemIndex - 1, 0, FItems.Count - 1));
|
||
Key := 0;
|
||
end;
|
||
VK_DOWN:
|
||
begin
|
||
if FItems.Count > 0 then
|
||
SetItemIndex(EnsureRange(FItemIndex + 1, 0, FItems.Count - 1));
|
||
Key := 0;
|
||
end;
|
||
VK_PRIOR:
|
||
begin
|
||
if FItems.Count > 0 then
|
||
SetItemIndex(EnsureRange(FItemIndex - VisibleCount, 0, FItems.Count - 1));
|
||
Key := 0;
|
||
end;
|
||
VK_NEXT:
|
||
begin
|
||
if FItems.Count > 0 then
|
||
SetItemIndex(EnsureRange(FItemIndex + VisibleCount, 0, FItems.Count - 1));
|
||
Key := 0;
|
||
end;
|
||
VK_HOME:
|
||
begin
|
||
if FItems.Count > 0 then
|
||
SetItemIndex(0);
|
||
Key := 0;
|
||
end;
|
||
VK_END:
|
||
begin
|
||
if FItems.Count > 0 then
|
||
SetItemIndex(FItems.Count - 1);
|
||
Key := 0;
|
||
end;
|
||
end;
|
||
if (Key = 0) and (FItemIndex <> OldIndex) then
|
||
Click;
|
||
end;
|
||
|
||
function TFlatListBox.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
|
||
begin
|
||
SetTopIndex(FTopIndex - 3);
|
||
Result := True;
|
||
end;
|
||
|
||
function TFlatListBox.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
|
||
begin
|
||
SetTopIndex(FTopIndex + 3);
|
||
Result := True;
|
||
end;
|
||
|
||
end.
|