// 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.