741 lines
21 KiB
ObjectPascal

// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit BCComboBox;
{$mode delphi}
interface
uses
{$ifdef WINDOWS}Windows,{$endif} Classes, SysUtils, LResources, Forms, Controls, ExtCtrls, Graphics, Dialogs, BCButton,
StdCtrls, BCTypes, BCBaseCtrls, BGRABitmap, BGRABitmapTypes, LMessages, LCLType;
type
{ TBCComboBox }
TBCComboBox = class(TBCStyleCustomControl)
private
FButton: TBCButton;
FCanvasScaleMode: TBCCanvasScaleMode;
FDropDownBorderSize: integer;
FDropDownCount: integer;
FDropDownColor: TColor;
FDropDownFontColor: TColor;
FDropDownFontHighlight: TColor;
FDropDownHighlight: TColor;
FFocusBorderColor: TColor;
FFocusBorderOpacity: byte;
FItems: TStringList;
FItemIndex: integer;
FForm: TForm;
FFormHideDate: TDateTime;
FHoverItem: integer;
FItemHeight: integer;
FListBox: TListBox;
FDropDownBorderColor: TColor;
FOnDrawItem: TDrawItemEvent;
FOnDrawSelectedItem: TOnAfterRenderBCButton;
FOnChange: TNotifyEvent;
FOnDropDown: TNotifyEvent;
FDrawingDropDown: boolean;
FTimerCheckFormHide: TTimer;
FQueryFormHide: boolean;
procedure ButtonClick(Sender: TObject);
procedure FormDeactivate(Sender: TObject);
procedure FormHide(Sender: TObject);
function GetArrowFlip: boolean;
function GetComboCanvas: TCanvas;
function GetArrowSize: integer;
function GetArrowWidth: integer;
function GetGlobalOpacity: byte;
function GetItemText: string;
function GetDropDownColor: TColor;
function GetItemIndex: integer;
function GetItems: TStrings;
function GetMemoryUsage: TBCButtonMemoryUsage;
function GetOnDrawSelectedItem: TOnAfterRenderBCButton;
function GetRounding: TBCRounding;
function GetStateClicked: TBCButtonState;
function GetStateHover: TBCButtonState;
function GetStateNormal: TBCButtonState;
function GetStaticButton: boolean;
procedure ListBoxKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState
);
procedure ListBoxMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
procedure ListBoxMouseLeave(Sender: TObject);
procedure ListBoxMouseMove(Sender: TObject; {%H-}Shift: TShiftState; X,
Y: Integer);
procedure ListBoxSelectionChange(Sender: TObject; {%H-}User: boolean);
procedure ListBoxDrawItem(Control: TWinControl; Index: Integer;
ARect: TRect; State: TOwnerDrawState);
procedure OnAfterRenderButton(Sender: TObject; const ABGRA: TBGRABitmap;
AState: TBCButtonState; ARect: TRect);
procedure OnTimerCheckFormHide(Sender: TObject);
procedure SetArrowFlip(AValue: boolean);
procedure SetArrowSize(AValue: integer);
procedure SetArrowWidth(AValue: integer);
procedure SetCanvasScaleMode(AValue: TBCCanvasScaleMode);
procedure SetDropDownColor(AValue: TColor);
procedure SetGlobalOpacity(AValue: byte);
procedure SetItemIndex(AValue: integer);
procedure SetItems(AValue: TStrings);
procedure SetMemoryUsage(AValue: TBCButtonMemoryUsage);
procedure SetOnDrawSelectedItem(AValue: TOnAfterRenderBCButton);
procedure SetRounding(AValue: TBCRounding);
procedure SetStateClicked(AValue: TBCButtonState);
procedure SetStateHover(AValue: TBCButtonState);
procedure SetStateNormal(AValue: TBCButtonState);
procedure SetStaticButton(AValue: boolean);
protected
function GetStyleExtension: String; override;
procedure WMSetFocus(var {%H-}Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_KILLFOCUS{$ELSE}WM_KILLFOCUS{$ENDIF};
procedure UpdateFocus(AFocused: boolean);
procedure KeyDown(var Key: Word; {%H-}Shift: TShiftState); override;
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
procedure CreateForm;
procedure FreeForm;
function GetListBox: TListBox;
procedure UpdateButtonCanvasScaleMode;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ Assign the properties from Source to this instance }
procedure Assign(Source: TPersistent); override;
procedure Clear;
property HoverItem: integer read FHoverItem;
property Button: TBCButton read FButton write FButton;
property ListBox: TListBox read GetListBox;
property Text: string read GetItemText;
published
property Anchors;
property Canvas: TCanvas read GetComboCanvas;
property CanvasScaleMode: TBCCanvasScaleMode read FCanvasScaleMode write SetCanvasScaleMode default csmAuto;
property Items: TStrings read GetItems write SetItems;
property ItemIndex: integer read GetItemIndex write SetItemIndex;
property ItemHeight: integer read FItemHeight write FItemHeight default 0;
property ArrowSize: integer read GetArrowSize write SetArrowSize;
property ArrowWidth: integer read GetArrowWidth write SetArrowWidth;
property ArrowFlip: boolean read GetArrowFlip write SetArrowFlip default false;
property FocusBorderColor: TColor read FFocusBorderColor write FFocusBorderColor default clBlack;
property FocusBorderOpacity: byte read FFocusBorderOpacity write FFocusBorderOpacity default 255;
property DropDownBorderColor: TColor read FDropDownBorderColor write FDropDownBorderColor default clWindowText;
property DropDownBorderSize: integer read FDropDownBorderSize write FDropDownBorderSize default 1;
property DropDownColor: TColor read GetDropDownColor write SetDropDownColor default clWindow;
property DropDownFontColor: TColor read FDropDownFontColor write FDropDownFontColor default clWindowText;
property DropDownCount: integer read FDropDownCount write FDropDownCount default 8;
property DropDownHighlight: TColor read FDropDownHighlight write FDropDownHighlight default clHighlight;
property DropDownFontHighlight: TColor read FDropDownFontHighlight write FDropDownFontHighlight default clHighlightText;
property GlobalOpacity: byte read GetGlobalOpacity write SetGlobalOpacity;
property MemoryUsage: TBCButtonMemoryUsage read GetMemoryUsage write SetMemoryUsage;
property Rounding: TBCRounding read GetRounding write SetRounding;
property StateClicked: TBCButtonState read GetStateClicked write SetStateClicked;
property StateHover: TBCButtonState read GetStateHover write SetStateHover;
property StateNormal: TBCButtonState read GetStateNormal write SetStateNormal;
property StaticButton: boolean read GetStaticButton write SetStaticButton;
property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;
property OnDrawSelectedItem: TOnAfterRenderBCButton read GetOnDrawSelectedItem write SetOnDrawSelectedItem;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property TabStop;
property TabOrder;
end;
procedure Register;
implementation
uses math, PropEdits, BGRAText;
procedure Register;
begin
RegisterComponents('BGRA Controls', [TBCComboBox]);
end;
{ TBCComboBox }
procedure TBCComboBox.ButtonClick(Sender: TObject);
const MinDelayReopen = 500/(1000*60*60*24);
var
p: TPoint;
h: Integer;
s: TSize;
begin
{$IFDEF DARWIN}
if Assigned(FForm) and not FForm.Visible then FreeForm;
{$ENDIF}
CreateForm;
if FForm.Visible then
FForm.Visible := false
else
if Now > FFormHideDate+MinDelayReopen then
begin
p := ControlToScreen(Point(FButton.Left, FButton.Top + FButton.Height));
FForm.Left := p.X;
FForm.Top := p.Y;
FForm.Color := FDropDownBorderColor;
FListBox.Font.Name := Button.StateNormal.FontEx.Name;
FListBox.Font.Style := Button.StateNormal.FontEx.Style;
FListBox.Font.Height := FontEmHeightSign*Button.StateNormal.FontEx.Height;
self.Canvas.Font.Assign(FListBox.Font);
if Assigned(FOnDrawItem) and (FItemHeight <> 0) then
h := FItemHeight else h := self.Canvas.GetTextHeight('Hg');
{$IFDEF WINDOWS}inc(h,6);{$ENDIF}
FListBox.ItemHeight := h;
{$IFDEF LINUX}inc(h,6);{$ENDIF}
{$IFDEF DARWIN}inc(h,2);{$ENDIF}
s := TSize.Create(FButton.Width, h*min(Items.Count, FDropDownCount) + 2*FDropDownBorderSize);
FForm.ClientWidth := s.cx;
FForm.ClientHeight := s.cy;
FListBox.SetBounds(FDropDownBorderSize,FDropDownBorderSize,
s.cx - 2*FDropDownBorderSize,
s.cy - 2*FDropDownBorderSize);
if FForm.Top + FForm.Height > Screen.WorkAreaTop + Screen.WorkAreaHeight then
FForm.Top := FForm.Top - FForm.Height - Self.Height;
if Assigned(FOnDropDown) then FOnDropDown(self);
FForm.Visible := True;
if FListBox.CanSetFocus then
FListBox.SetFocus;
FTimerCheckFormHide.Enabled:= true;
FQueryFormHide := false;
end;
end;
procedure TBCComboBox.FormDeactivate(Sender: TObject);
begin
FQueryFormHide := true;
end;
procedure TBCComboBox.FormHide(Sender: TObject);
begin
FFormHideDate := Now;
end;
function TBCComboBox.GetArrowFlip: boolean;
begin
result := Button.FlipArrow;
end;
function TBCComboBox.GetComboCanvas: TCanvas;
begin
if FDrawingDropDown then
result := ListBox.Canvas
else
result := inherited Canvas;
end;
function TBCComboBox.GetArrowSize: integer;
begin
result := Button.DropDownArrowSize;
end;
function TBCComboBox.GetArrowWidth: integer;
begin
result := Button.DropDownWidth;
end;
function TBCComboBox.GetGlobalOpacity: byte;
begin
result := Button.GlobalOpacity;
end;
function TBCComboBox.GetItemText: string;
begin
if ItemIndex<>-1 then
result := Items[ItemIndex]
else
result := '';
end;
function TBCComboBox.GetDropDownColor: TColor;
begin
if Assigned(FListBox) then
result := FListBox.Color
else result := FDropDownColor;
end;
function TBCComboBox.GetItemIndex: integer;
begin
if Assigned(FListBox) then
result := FListBox.ItemIndex
else
begin
if FItemIndex >= Items.Count then
FItemIndex := -1;
result := FItemIndex;
end;
end;
function TBCComboBox.GetItems: TStrings;
begin
if Assigned(FListBox) then
Result := FListBox.Items
else Result := FItems;
end;
function TBCComboBox.GetMemoryUsage: TBCButtonMemoryUsage;
begin
result := Button.MemoryUsage;
end;
function TBCComboBox.GetOnDrawSelectedItem: TOnAfterRenderBCButton;
begin
result := FOnDrawSelectedItem;
end;
function TBCComboBox.GetRounding: TBCRounding;
begin
result := Button.Rounding;
end;
function TBCComboBox.GetStateClicked: TBCButtonState;
begin
result := Button.StateClicked;
end;
function TBCComboBox.GetStateHover: TBCButtonState;
begin
result := Button.StateHover;
end;
function TBCComboBox.GetStateNormal: TBCButtonState;
begin
result := Button.StateNormal;
end;
function TBCComboBox.GetStaticButton: boolean;
begin
result := Button.StaticButton;
end;
procedure TBCComboBox.ListBoxKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key = VK_RETURN) or (Key = VK_ESCAPE) then
begin
ButtonClick(nil);
Key := 0;
end;
end;
procedure TBCComboBox.ListBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FQueryFormHide := true;
end;
procedure TBCComboBox.ListBoxMouseLeave(Sender: TObject);
begin
FHoverItem := -1;
FListBox.Repaint;
end;
procedure TBCComboBox.ListBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
TempItem: integer;
begin
TempItem := FListBox.ItemAtPos(Point(x, y), True);
if TempItem <> FHoverItem then
begin
FHoverItem := TempItem;
if (FHoverItem<>-1) and ([ssLeft,ssRight]*Shift <> []) then
FListBox.ItemIndex := FHoverItem;
FListBox.Repaint;
end;
end;
procedure TBCComboBox.ListBoxSelectionChange(Sender: TObject; User: boolean);
begin
Button.Caption := GetItemText;
if User and Assigned(FOnChange) then FOnChange(self);
end;
procedure TBCComboBox.ListBoxDrawItem(Control: TWinControl; Index: Integer;
ARect: TRect; State: TOwnerDrawState);
var
aCanvas: TCanvas;
begin
if Assigned(FOnDrawItem) then
begin
FDrawingDropDown := true;
Exclude(State, odSelected);
if Index = HoverItem then Include(State, odSelected);
if Index = ItemIndex then Include(State, odChecked);
try
FOnDrawItem(Control, Index, ARect, State);
finally
FDrawingDropDown := false;
end;
exit;
end;
aCanvas := TListBox(Control).Canvas;
if Index = HoverItem then
begin
aCanvas.Brush.Color := DropDownHighlight;
aCanvas.Font.Color := DropDownFontHighlight;
end
else
begin
aCanvas.Brush.Color := DropDownColor;
aCanvas.Font.Color := DropDownFontColor;
end;
aCanvas.Pen.Style := psClear;
aCanvas.FillRect(ARect);
aCanvas.TextRect(ARect, ARect.Left+4, ARect.Top +
(ARect.Height - aCanvas.GetTextHeight(Items[Index])) div 2,
Items[Index]);
end;
procedure TBCComboBox.OnAfterRenderButton(Sender: TObject;
const ABGRA: TBGRABitmap; AState: TBCButtonState; ARect: TRect);
var
focusMargin: integer;
begin
if Assigned(FOnDrawSelectedItem) then
FOnDrawSelectedItem(self, ABGRA, AState, ARect);
if Focused then
begin
focusMargin := round(2 * Button.CanvasScale);
ABGRA.RectangleAntialias(ARect.Left + focusMargin, ARect.Top + focusMargin,
ARect.Right - focusMargin - 1, ARect.Bottom - focusMargin - 1,
ColorToBGRA(FocusBorderColor, FocusBorderOpacity),
Button.CanvasScale);
end;
end;
procedure TBCComboBox.OnTimerCheckFormHide(Sender: TObject);
{$ifdef WINDOWS}
function IsDropDownOnTop: boolean;
begin
result := Assigned(FForm) and (GetForegroundWindow = FForm.Handle);
end;
{$endif}
begin
if Assigned(FForm) and FForm.Visible and
({$IFDEF DARWIN}not FForm.Active or {$ENDIF}
{$IFDEF WINDOWS}not IsDropDownOnTop or{$ENDIF}
FQueryFormHide) then
begin
FForm.Visible := false;
FQueryFormHide := false;
FTimerCheckFormHide.Enabled := false;
end;
end;
procedure TBCComboBox.SetArrowFlip(AValue: boolean);
begin
Button.FlipArrow:= AValue;
end;
procedure TBCComboBox.SetArrowSize(AValue: integer);
begin
Button.DropDownArrowSize:= AValue;
end;
procedure TBCComboBox.SetArrowWidth(AValue: integer);
begin
Button.DropDownWidth:= AValue;
end;
procedure TBCComboBox.SetCanvasScaleMode(AValue: TBCCanvasScaleMode);
begin
if FCanvasScaleMode=AValue then Exit;
FCanvasScaleMode:=AValue;
UpdateButtonCanvasScaleMode;
end;
procedure TBCComboBox.SetDropDownColor(AValue: TColor);
begin
if Assigned(FListBox) then
FListBox.Color := AValue
else FDropDownColor:= AValue;
end;
procedure TBCComboBox.SetGlobalOpacity(AValue: byte);
begin
Button.GlobalOpacity := AValue;
end;
procedure TBCComboBox.SetItemIndex(AValue: integer);
begin
if Assigned(FListBox) then
FListBox.ItemIndex := AValue
else
begin
if AValue <> FItemIndex then
begin
FItemIndex := AValue;
Button.Caption := GetItemText;
end;
end;
end;
procedure TBCComboBox.SetItems(AValue: TStrings);
begin
if Assigned(FListBox) then
FListBox.Items.Assign(AValue)
else FItems.Assign(AValue);
end;
procedure TBCComboBox.SetMemoryUsage(AValue: TBCButtonMemoryUsage);
begin
Button.MemoryUsage := AValue;
end;
procedure TBCComboBox.SetOnDrawSelectedItem(AValue: TOnAfterRenderBCButton);
begin
if @FOnDrawSelectedItem = @AValue then Exit;
FOnDrawSelectedItem:= AValue;
FButton.ShowCaption := not Assigned(AValue);
UpdateButtonCanvasScaleMode;
end;
procedure TBCComboBox.SetRounding(AValue: TBCRounding);
begin
Button.Rounding := AValue;
end;
procedure TBCComboBox.SetStateClicked(AValue: TBCButtonState);
begin
Button.StateClicked := AValue;
end;
procedure TBCComboBox.SetStateHover(AValue: TBCButtonState);
begin
Button.StateHover := AValue;
end;
procedure TBCComboBox.SetStateNormal(AValue: TBCButtonState);
begin
Button.StateNormal := AValue;
end;
procedure TBCComboBox.SetStaticButton(AValue: boolean);
begin
Button.StaticButton:= AValue;
end;
function TBCComboBox.GetStyleExtension: String;
begin
result := 'bccombo';
end;
procedure TBCComboBox.WMSetFocus(var Message: TLMSetFocus);
begin
UpdateFocus(True);
end;
procedure TBCComboBox.WMKillFocus(var Message: TLMKillFocus);
begin
if Message.FocusedWnd <> Handle then
UpdateFocus(False);
end;
procedure TBCComboBox.UpdateFocus(AFocused: boolean);
var
lForm: TCustomForm;
oldCaption: string;
begin
lForm := GetParentForm(Self);
if lForm = nil then
exit;
{$IFDEF FPC}//#
if AFocused then
ActiveDefaultControlChanged(lForm.ActiveControl)
else
ActiveDefaultControlChanged(nil);
{$ENDIF}
oldCaption := FButton.Caption;
FButton.Caption := FButton.Caption + '1';
FButton.Caption := oldCaption;
Invalidate;
end;
procedure TBCComboBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
if Key = VK_RETURN then
begin
ButtonClick(nil);
Key := 0;
end
else if Key = VK_DOWN then
begin
if ItemIndex + 1 < Items.Count then
begin
ItemIndex := ItemIndex + 1;
Button.Caption := GetItemText;
if Assigned(FOnChange) then
FOnChange(Self);
end;
Key := 0;
end
else if Key = VK_UP then
begin
if ItemIndex - 1 >= 0 then
begin
ItemIndex := ItemIndex - 1;
Button.Caption := GetItemText;
if Assigned(FOnChange) then
FOnChange(Self);
end;
Key := 0;
end;
end;
procedure TBCComboBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
var
i: integer;
begin
for i:=0 to Items.Count-1 do
begin
if (Items[i] <> '') and Items[i].ToLower.StartsWith(LowerCase(UTF8Key)) then
begin
if ItemIndex <> i then
begin
ItemIndex := i;
Button.Caption := GetItemText;
if Assigned(FOnChange) then
FOnChange(Self);
break;
end;
end;
end;
end;
procedure TBCComboBox.CreateForm;
begin
if FForm = nil then
begin
FForm := TForm.Create(Self);
FForm.Visible := False;
FForm.ShowInTaskBar:= stNever;
FForm.BorderStyle := bsNone;
FForm.OnDeactivate:= FormDeactivate;
FForm.OnHide:=FormHide;
FForm.FormStyle := fsStayOnTop;
end;
if FListBox = nil then
begin
FListBox := TListBox.Create(self);
FListBox.Parent := FForm;
FListBox.BorderStyle := bsNone;
FListBox.OnSelectionChange := ListBoxSelectionChange;
FListBox.OnMouseLeave:=ListBoxMouseLeave;
FListBox.OnMouseMove:=ListBoxMouseMove;
FListBox.OnMouseUp:= ListBoxMouseUp;
FListBox.Style := lbOwnerDrawFixed;
FListBox.OnDrawItem:= ListBoxDrawItem;
FListBox.Options := []; // do not draw focus rect
FListBox.OnKeyDown:=ListBoxKeyDown;
if Assigned(FItems) then
begin
FListBox.Items.Assign(FItems);
FreeAndNil(FItems);
end;
FListBox.ItemIndex := FItemIndex;
FListBox.Color := FDropDownColor;
end;
end;
procedure TBCComboBox.FreeForm;
begin
if Assigned(FListBox) then
begin
if FListBox.LCLRefCount > 0 then exit;
if FItems = nil then
FItems := TStringList.Create;
FItems.Assign(FListBox.Items);
FItemIndex := FListBox.ItemIndex;
FDropDownColor:= FListBox.Color;
FreeAndNil(FListBox);
end;
FreeAndNil(FForm);
end;
function TBCComboBox.GetListBox: TListBox;
begin
CreateForm;
result := FListBox;
end;
procedure TBCComboBox.UpdateButtonCanvasScaleMode;
begin
if (CanvasScaleMode = csmFullResolution) or
((CanvasScaleMode = csmAuto) and not Assigned(FOnDrawSelectedItem)) then
FButton.CanvasScaleMode:= csmFullResolution
else FButton.CanvasScaleMode:= csmScaleBitmap;
end;
constructor TBCComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FButton := TBCButton.Create(Self);
FButton.Align := alClient;
FButton.Parent := Self;
FButton.OnClick := ButtonClick;
FButton.DropDownArrow := True;
FButton.OnAfterRenderBCButton := OnAfterRenderButton;
UpdateButtonCanvasScaleMode;
FItems := TStringList.Create;
FHoverItem := -1;
FItemIndex := -1;
DropDownBorderSize := 1;
DropDownColor := clWindow;
DropDownBorderColor := clWindowText;
DropDownCount := 8;
DropDownFontColor := clWindowText;
DropDownHighlight := clHighlight;
DropDownFontHighlight := clHighlightText;
FTimerCheckFormHide := TTimer.Create(self);
FTimerCheckFormHide.Interval:= 30;
FTimerCheckFormHide.OnTimer:= OnTimerCheckFormHide;
end;
destructor TBCComboBox.Destroy;
begin
FreeAndNil(FItems);
inherited Destroy;
end;
procedure TBCComboBox.Assign(Source: TPersistent);
var
src: TBCComboBox;
begin
if Source is TBCComboBox then
begin
src := TBCComboBox(Source);
Button.Assign(src.Button);
Items.Assign(src.Items);
ItemIndex := src.ItemIndex;
DropDownBorderColor := src.DropDownBorderColor;
DropDownBorderSize := src.DropDownBorderSize;
DropDownColor := src.DropDownColor;
DropDownFontColor := src.DropDownFontColor;
DropDownCount := src.DropDownCount;
DropDownHighlight := src.DropDownHighlight;
DropDownFontHighlight := src.DropDownFontHighlight;
end else
inherited Assign(Source);
end;
procedure TBCComboBox.Clear;
begin
Items.Clear;
end;
end.