mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 19:45:09 +00:00
Add custom flat form controls
This commit is contained in:
@@ -0,0 +1,532 @@
|
||||
unit FlatComboBox;
|
||||
|
||||
{ Custom drop-down list with canvas rendering.
|
||||
Use instead of TComboBox where native widgetset styling is undesirable. }
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Controls, Graphics, Forms, LCLType, LMessages, Types,
|
||||
Math, AppTheme;
|
||||
|
||||
type
|
||||
TFlatComboBox = class;
|
||||
|
||||
TFlatComboPopup = class(TCustomControl)
|
||||
private
|
||||
FCombo: TFlatComboBox;
|
||||
FHotIndex: Integer;
|
||||
FTopIndex: Integer;
|
||||
function ItemAt(Y: Integer): Integer;
|
||||
procedure EnsureHotVisible;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer); override;
|
||||
procedure DoExit; 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 CreatePopup(AOwner: TComponent; ACombo: TFlatComboBox); reintroduce;
|
||||
end;
|
||||
|
||||
TFlatComboBox = class(TCustomControl)
|
||||
private
|
||||
FItems: TStringList;
|
||||
FItemIndex: Integer;
|
||||
FHot: Boolean;
|
||||
FDown: Boolean;
|
||||
FPopup: TFlatComboPopup;
|
||||
FOnChange: TNotifyEvent;
|
||||
FClrOuterBG: TColor;
|
||||
FClrBG: TColor;
|
||||
FClrBGHot: TColor;
|
||||
FClrBorder: TColor;
|
||||
FClrBorderHot: TColor;
|
||||
FClrText: TColor;
|
||||
FClrTextDim: TColor;
|
||||
FClrPopupBG: TColor;
|
||||
FClrPopupHot: TColor;
|
||||
FClrPopupSel: TColor;
|
||||
function DpiScale(V: Integer): Integer;
|
||||
function ItemHeight: Integer;
|
||||
function ArrowWidth: Integer;
|
||||
procedure ItemsChanged(Sender: TObject);
|
||||
procedure SetItemIndex(V: Integer);
|
||||
function GetText: string;
|
||||
procedure SetText(const V: string);
|
||||
procedure DoChange;
|
||||
procedure ClosePopup;
|
||||
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 MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer); override;
|
||||
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure SetAppTheme(const T: TAppTheme);
|
||||
procedure DropDown;
|
||||
|
||||
property Items: TStringList read FItems;
|
||||
property ItemIndex: Integer read FItemIndex write SetItemIndex;
|
||||
property Text: string read GetText write SetText;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
property TabOrder;
|
||||
property TabStop;
|
||||
property Tag;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
BASE_ITEM_H = 24;
|
||||
BASE_ARROW_W = 24;
|
||||
BASE_PAD = 8;
|
||||
|
||||
{ TFlatComboPopup }
|
||||
|
||||
constructor TFlatComboPopup.CreatePopup(AOwner: TComponent; ACombo: TFlatComboBox);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FCombo := ACombo;
|
||||
FHotIndex := ACombo.ItemIndex;
|
||||
FTopIndex := Max(0, FHotIndex - 4);
|
||||
TabStop := True;
|
||||
Cursor := crDefault;
|
||||
Color := ACombo.FClrPopupBG;
|
||||
end;
|
||||
|
||||
function TFlatComboPopup.ItemAt(Y: Integer): Integer;
|
||||
begin
|
||||
Result := FTopIndex + Y div FCombo.ItemHeight;
|
||||
if (Result < 0) or (Result >= FCombo.Items.Count) then
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
procedure TFlatComboPopup.EnsureHotVisible;
|
||||
var
|
||||
VisibleCount: Integer;
|
||||
begin
|
||||
VisibleCount := Max(1, Height div FCombo.ItemHeight);
|
||||
if FHotIndex < FTopIndex then
|
||||
FTopIndex := FHotIndex
|
||||
else if FHotIndex >= FTopIndex + VisibleCount then
|
||||
FTopIndex := FHotIndex - VisibleCount + 1;
|
||||
FTopIndex := EnsureRange(FTopIndex, 0, Max(0, FCombo.Items.Count - VisibleCount));
|
||||
end;
|
||||
|
||||
procedure TFlatComboPopup.Paint;
|
||||
var
|
||||
i, ItemIdx, Y, TextY, VisibleCount: Integer;
|
||||
R: TRect;
|
||||
begin
|
||||
Canvas.Brush.Color := FCombo.FClrPopupBG;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
Canvas.Pen.Style := psClear;
|
||||
Canvas.FillRect(ClientRect);
|
||||
|
||||
Canvas.Font.Assign(FCombo.Font);
|
||||
VisibleCount := Max(1, Height div FCombo.ItemHeight);
|
||||
for i := 0 to VisibleCount - 1 do
|
||||
begin
|
||||
ItemIdx := FTopIndex + i;
|
||||
if ItemIdx >= FCombo.Items.Count then Break;
|
||||
Y := i * FCombo.ItemHeight;
|
||||
R := Rect(0, Y, Width, Y + FCombo.ItemHeight);
|
||||
if ItemIdx = FCombo.ItemIndex then
|
||||
Canvas.Brush.Color := FCombo.FClrPopupSel
|
||||
else if ItemIdx = FHotIndex then
|
||||
Canvas.Brush.Color := FCombo.FClrPopupHot
|
||||
else
|
||||
Canvas.Brush.Color := FCombo.FClrPopupBG;
|
||||
Canvas.FillRect(R);
|
||||
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Font.Color := FCombo.FClrText;
|
||||
TextY := Y + (FCombo.ItemHeight - Canvas.TextHeight('Ag')) div 2;
|
||||
Canvas.TextOut(FCombo.DpiScale(BASE_PAD), TextY, FCombo.Items[ItemIdx]);
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
end;
|
||||
|
||||
Canvas.Pen.Color := FCombo.FClrBorder;
|
||||
Canvas.Pen.Style := psSolid;
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Rectangle(0, 0, Width, Height);
|
||||
end;
|
||||
|
||||
procedure TFlatComboPopup.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 TFlatComboPopup.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
var
|
||||
Idx: Integer;
|
||||
begin
|
||||
inherited;
|
||||
if Button <> mbLeft then Exit;
|
||||
if PtInRect(ClientRect, Point(X, Y)) then
|
||||
begin
|
||||
Idx := ItemAt(Y);
|
||||
if Idx >= 0 then
|
||||
FCombo.ItemIndex := Idx;
|
||||
end;
|
||||
FCombo.ClosePopup;
|
||||
end;
|
||||
|
||||
procedure TFlatComboPopup.DoExit;
|
||||
begin
|
||||
inherited;
|
||||
if Assigned(FCombo) then
|
||||
FCombo.ClosePopup;
|
||||
end;
|
||||
|
||||
procedure TFlatComboPopup.KeyDown(var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
case Key of
|
||||
VK_ESCAPE:
|
||||
begin
|
||||
FCombo.ClosePopup;
|
||||
Key := 0;
|
||||
end;
|
||||
VK_RETURN:
|
||||
begin
|
||||
if FHotIndex >= 0 then
|
||||
FCombo.ItemIndex := FHotIndex;
|
||||
FCombo.ClosePopup;
|
||||
Key := 0;
|
||||
end;
|
||||
VK_UP:
|
||||
begin
|
||||
FHotIndex := EnsureRange(FHotIndex - 1, 0, FCombo.Items.Count - 1);
|
||||
EnsureHotVisible;
|
||||
Invalidate;
|
||||
Key := 0;
|
||||
end;
|
||||
VK_DOWN:
|
||||
begin
|
||||
FHotIndex := EnsureRange(FHotIndex + 1, 0, FCombo.Items.Count - 1);
|
||||
EnsureHotVisible;
|
||||
Invalidate;
|
||||
Key := 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFlatComboPopup.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
|
||||
begin
|
||||
FTopIndex := Max(0, FTopIndex - 1);
|
||||
Invalidate;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function TFlatComboPopup.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
|
||||
var
|
||||
VisibleCount: Integer;
|
||||
begin
|
||||
VisibleCount := Max(1, Height div FCombo.ItemHeight);
|
||||
FTopIndex := Min(Max(0, FCombo.Items.Count - VisibleCount), FTopIndex + 1);
|
||||
Invalidate;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
{ TFlatComboBox }
|
||||
|
||||
constructor TFlatComboBox.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents];
|
||||
FItems := TStringList.Create;
|
||||
FItems.OnChange := @ItemsChanged;
|
||||
FItemIndex := -1;
|
||||
Width := 140;
|
||||
Height := DpiScale(26);
|
||||
TabStop := True;
|
||||
Cursor := crDefault;
|
||||
|
||||
Font.Name := 'Courier New';
|
||||
Font.Size := 9;
|
||||
|
||||
FClrBG := TColor($001A1A1A);
|
||||
FClrOuterBG := TColor($00181818);
|
||||
FClrBGHot := TColor($00282828);
|
||||
FClrBorder := TColor($00444444);
|
||||
FClrBorderHot := TColor($00387838);
|
||||
FClrText := TColor($00E0E0E0);
|
||||
FClrTextDim := TColor($00888888);
|
||||
FClrPopupBG := TColor($00181818);
|
||||
FClrPopupHot := TColor($000C3010);
|
||||
FClrPopupSel := TColor($00183618);
|
||||
end;
|
||||
|
||||
function TFlatComboBox.DpiScale(V: Integer): Integer;
|
||||
begin
|
||||
Result := MulDiv(V, Screen.PixelsPerInch, 96);
|
||||
if (V > 0) and (Result < 1) then
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
function TFlatComboBox.ItemHeight: Integer;
|
||||
begin
|
||||
Result := DpiScale(BASE_ITEM_H);
|
||||
if Result < Canvas.TextHeight('Ag') + DpiScale(8) then
|
||||
Result := Canvas.TextHeight('Ag') + DpiScale(8);
|
||||
end;
|
||||
|
||||
function TFlatComboBox.ArrowWidth: Integer;
|
||||
begin
|
||||
Result := DpiScale(BASE_ARROW_W);
|
||||
end;
|
||||
|
||||
destructor TFlatComboBox.Destroy;
|
||||
begin
|
||||
ClosePopup;
|
||||
FItems.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.SetAppTheme(const T: TAppTheme);
|
||||
begin
|
||||
FClrBG := T.BtnNorm;
|
||||
FClrOuterBG := T.Panel;
|
||||
FClrBGHot := T.BtnHot;
|
||||
FClrBorder := T.Border;
|
||||
FClrBorderHot := T.Border;
|
||||
FClrText := T.Text;
|
||||
FClrTextDim := T.TextDim;
|
||||
FClrPopupBG := T.Panel;
|
||||
FClrPopupHot := T.BtnActive;
|
||||
FClrPopupSel := T.SliderTrackFill;
|
||||
Font.Color := T.Text;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.ItemsChanged(Sender: TObject);
|
||||
begin
|
||||
if FItemIndex >= FItems.Count then
|
||||
FItemIndex := FItems.Count - 1;
|
||||
if FItems.Count = 0 then
|
||||
FItemIndex := -1;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.SetItemIndex(V: Integer);
|
||||
begin
|
||||
V := EnsureRange(V, -1, FItems.Count - 1);
|
||||
if FItemIndex = V then Exit;
|
||||
FItemIndex := V;
|
||||
Invalidate;
|
||||
DoChange;
|
||||
end;
|
||||
|
||||
function TFlatComboBox.GetText: string;
|
||||
begin
|
||||
if (FItemIndex >= 0) and (FItemIndex < FItems.Count) then
|
||||
Result := FItems[FItemIndex]
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.SetText(const V: string);
|
||||
var
|
||||
Idx: Integer;
|
||||
begin
|
||||
Idx := FItems.IndexOf(V);
|
||||
if Idx >= 0 then
|
||||
ItemIndex := Idx
|
||||
else
|
||||
begin
|
||||
FItems.Add(V);
|
||||
ItemIndex := FItems.Count - 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.DoChange;
|
||||
begin
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.ClosePopup;
|
||||
begin
|
||||
if FPopup = nil then Exit;
|
||||
FPopup.MouseCapture := False;
|
||||
FreeAndNil(FPopup);
|
||||
FDown := False;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.DropDown;
|
||||
var
|
||||
Root: TCustomForm;
|
||||
P: TPoint;
|
||||
H, IH: Integer;
|
||||
begin
|
||||
if (FPopup <> nil) or (FItems.Count = 0) then Exit;
|
||||
Root := GetParentForm(Self);
|
||||
if Root = nil then Exit;
|
||||
P := Root.ScreenToClient(ClientToScreen(Point(0, Height)));
|
||||
IH := ItemHeight;
|
||||
H := Min(FItems.Count * IH + 1, IH * 10 + 1);
|
||||
if P.Y + H > Root.ClientHeight then
|
||||
P.Y := Root.ScreenToClient(ClientToScreen(Point(0, 0))).Y - H;
|
||||
if P.Y < 0 then
|
||||
P.Y := 0;
|
||||
|
||||
FPopup := TFlatComboPopup.CreatePopup(Root, Self);
|
||||
FPopup.Parent := Root;
|
||||
FPopup.SetBounds(P.X, P.Y, Width, H);
|
||||
FPopup.BringToFront;
|
||||
FPopup.Visible := True;
|
||||
FPopup.SetFocus;
|
||||
FPopup.MouseCapture := True;
|
||||
FDown := True;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.CMTextChanged(var Msg: TLMessage);
|
||||
begin
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.Paint;
|
||||
var
|
||||
R: TRect;
|
||||
TextY, MidY, X, Pad, AW, Chevron: Integer;
|
||||
BG, Bdr: TColor;
|
||||
S: string;
|
||||
begin
|
||||
R := ClientRect;
|
||||
if FHot or FDown or Focused then
|
||||
begin
|
||||
BG := FClrBGHot;
|
||||
Bdr := FClrBorderHot;
|
||||
end
|
||||
else
|
||||
begin
|
||||
BG := FClrBG;
|
||||
Bdr := FClrBorder;
|
||||
end;
|
||||
|
||||
Canvas.Brush.Color := FClrOuterBG;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
Canvas.Pen.Style := psClear;
|
||||
Canvas.FillRect(R);
|
||||
|
||||
Canvas.Brush.Color := BG;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
Canvas.Pen.Color := Bdr;
|
||||
Canvas.Pen.Style := psSolid;
|
||||
Canvas.Pen.Width := 1;
|
||||
Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
|
||||
|
||||
Pad := DpiScale(BASE_PAD);
|
||||
AW := ArrowWidth;
|
||||
Canvas.Font.Assign(Font);
|
||||
if Enabled then
|
||||
Canvas.Font.Color := FClrText
|
||||
else
|
||||
Canvas.Font.Color := FClrTextDim;
|
||||
Canvas.Brush.Style := bsClear;
|
||||
S := Text;
|
||||
TextY := (Height - Canvas.TextHeight('Ag')) div 2;
|
||||
Canvas.TextRect(Rect(Pad, 0, Width - AW - DpiScale(4), Height), Pad, TextY, S);
|
||||
|
||||
X := Width - AW div 2;
|
||||
MidY := Height div 2;
|
||||
Chevron := DpiScale(4);
|
||||
Canvas.Pen.Color := FClrTextDim;
|
||||
Canvas.Pen.Style := psSolid;
|
||||
Canvas.Pen.Width := Max(1, DpiScale(2));
|
||||
Canvas.Line(X - Chevron, MidY - Chevron div 2, X, MidY + Chevron div 2);
|
||||
Canvas.Line(X, MidY + Chevron div 2, X + Chevron, MidY - Chevron div 2);
|
||||
Canvas.Pen.Width := 1;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.MouseEnter;
|
||||
begin
|
||||
inherited;
|
||||
FHot := True;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.MouseLeave;
|
||||
begin
|
||||
inherited;
|
||||
FHot := False;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = mbLeft) and Enabled then
|
||||
SetFocus;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = mbLeft) and Enabled and PtInRect(ClientRect, Point(X, Y)) then
|
||||
begin
|
||||
if FPopup <> nil then
|
||||
ClosePopup
|
||||
else
|
||||
DropDown;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFlatComboBox.KeyDown(var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
case Key of
|
||||
VK_SPACE, VK_RETURN:
|
||||
begin
|
||||
DropDown;
|
||||
Key := 0;
|
||||
end;
|
||||
VK_UP:
|
||||
begin
|
||||
ItemIndex := FItemIndex - 1;
|
||||
Key := 0;
|
||||
end;
|
||||
VK_DOWN:
|
||||
begin
|
||||
ItemIndex := FItemIndex + 1;
|
||||
Key := 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user