diff --git a/components/exctrls/exctrlspkg.lpk b/components/exctrls/exctrlspkg.lpk index 93dbdd1b7..dc2a7235f 100644 --- a/components/exctrls/exctrlspkg.lpk +++ b/components/exctrls/exctrlspkg.lpk @@ -15,9 +15,10 @@ +- TRadioButton, TCheckbox, TRadioGroup and TCheckGroup: drawn by ThemeServices/Canvas, not by widgetset, button/text layout, wordwrap, user-provided check images +- TColumnComboBoxEx"/> - + @@ -35,6 +36,10 @@ + + + + diff --git a/components/exctrls/exctrlspkg.pas b/components/exctrls/exctrlspkg.pas index ed4fb1d19..d1f919833 100644 --- a/components/exctrls/exctrlspkg.pas +++ b/components/exctrls/exctrlspkg.pas @@ -8,7 +8,7 @@ unit ExCtrlsPkg; interface uses - ExCheckCtrls, ExEditCtrls, ExCtrlsReg, ExButtons, LazarusPackageIntf; + ExCheckCtrls, ExEditCtrls, ExCtrlsReg, ExButtons, ExCombo, LazarusPackageIntf; implementation diff --git a/components/exctrls/images/imagelist.txt b/components/exctrls/images/imagelist.txt index 534a6f288..969e87d03 100644 --- a/components/exctrls/images/imagelist.txt +++ b/components/exctrls/images/imagelist.txt @@ -19,3 +19,6 @@ tcurrspineditex_200.png tfloatsispineditex.png tfloatsispineditex_150.png tfloatsispineditex_200.png +tcolumncomboboxex.png +tcolumncomboboxex_150.png +tcolumncomboboxex_200.png diff --git a/components/exctrls/images/tcolumncomboboxex.png b/components/exctrls/images/tcolumncomboboxex.png new file mode 100644 index 000000000..4a76b2bbd Binary files /dev/null and b/components/exctrls/images/tcolumncomboboxex.png differ diff --git a/components/exctrls/images/tcolumncomboboxex_150.png b/components/exctrls/images/tcolumncomboboxex_150.png new file mode 100644 index 000000000..3a44cef4d Binary files /dev/null and b/components/exctrls/images/tcolumncomboboxex_150.png differ diff --git a/components/exctrls/images/tcolumncomboboxex_200.png b/components/exctrls/images/tcolumncomboboxex_200.png new file mode 100644 index 000000000..339165815 Binary files /dev/null and b/components/exctrls/images/tcolumncomboboxex_200.png differ diff --git a/components/exctrls/source/excombo.pas b/components/exctrls/source/excombo.pas new file mode 100644 index 000000000..c9ddaf8bf --- /dev/null +++ b/components/exctrls/source/excombo.pas @@ -0,0 +1,413 @@ +{ TColumnCombo is a text-only combobox that displays its dropdown items list in + single phrase columns, which are parsed according to the (Char) Delimiter + property. + Column width in the dropdown is adjusted automatically to accomomodate the + longest word/phrase in each column. + The number of columns shown depends entirely on the number of delimiters found + in each listed item, hence is an unpublished read-only property. + The default delimiter is the comma. + There is a display property -- commented out -- ShowColSeparators (False by + default) which displays vertical lines between the listed columns. It seems ugly to me, + so I disabled it, but you can re-enable it if you want. + The ColumnMargin property allows for adjustment of all column widths by a fixed amount. + + H Page-Clark 2013 + + + License: + + This library is free software; you can redistribute it and/or modify it + under the same terms as the Lazarus Component Library (LCL) + + See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution, + for details about the license. +} + +unit ExCombo; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Graphics, Types, + StdCtrls, Controls, Forms; + +type + + TColumnComboBoxEx = class(TCustomComboBox) + private + FColumnCount: Integer; + FColumnMargin: Integer; + FDelimiter: AnsiChar; + FOffsets: TIntegerDynArray; + FParser: TStringList; + FColSeparatorColor: TColor; + FShowColSeparators: Boolean; + FTextHeight: Integer; + function ColumnMarginStored: Boolean; + function GetTextSize(const aText: String): TSize; + function GetColumnCount: Integer; + function GetDelimiteds(const aLine: String): TStringArray; + procedure SetColSeparatorColor(AValue: TColor); + procedure SetColumnMargin(aValue: Integer); + procedure SetDelimiter(aValue: AnsiChar); + procedure SetOffsets; + procedure SetShowColSeparators(aValue: Boolean); + protected + procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; + const AXProportion, AYProportion: Double); override; + class function GetControlClassDefaultSize: TSize; override; + procedure GetItems; override; + procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); override; + procedure FontChanged(Sender: TObject); override; + procedure SetItems(const Value: TStrings); override; + procedure SetStyle(AValue: TComboBoxStyle); override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + property ColumnCount: Integer read FColumnCount; + published + // new properties + property ColumnMargin: Integer read FColumnMargin write SetColumnMargin stored ColumnMarginStored; + property ColSeparatorColor: TColor read FColSeparatorColor write SetColSeparatorColor default clSilver; + property Delimiter: AnsiChar read FDelimiter write SetDelimiter default ','; + property ShowColSeparators: Boolean read FShowColSeparators write SetShowColSeparators default False; + // inherited comboBox properties + property Align; + property Anchors; + property ArrowKeysTraverseList; + property AutoComplete; + property AutoCompleteText; + property AutoDropDown; + property AutoSelect; + property AutoSize; + property BidiMode; + property BorderSpacing; + property BorderStyle; + property CharCase; + property Color default clWindow; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property DropDownCount; + property Enabled; + property Font; + property ItemHeight; + property ItemIndex; + property Items; + property ItemWidth; + property MaxLength; + property OnChange; + property OnChangeBounds; + property OnClick; + property OnCloseUp; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnEndDrag; + property OnDropDown; + property OnEditingDone; + property OnEnter; + property OnExit; + property OnGetItems; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnSelect; + property OnUTF8KeyPress; + property ParentBidiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Sorted; + property Style default csOwnerDrawFixed; + property TabOrder; + property TabStop; + property Text; + property Visible; + end; + + +implementation + +uses + LCLType, LCLIntf; + +const + DEFAULT_COLUMN_MARGIN = 4; + +{ TColumnCombo } + +constructor TColumnComboBoxEx.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + Color := clWindow; + + FParser := TStringList.Create; + FColumnMargin := DEFAULT_COLUMN_MARGIN; + FColumnCount := 0; + FColSeparatorColor := clSilver; + FDelimiter := ','; + FShowColSeparators := False; + SetStyle(csOwnerDrawFixed); + FOffsets := nil; + FColumnCount := 0; +end; + +destructor TColumnComboBoxEx.Destroy; +begin + FParser.Free; + inherited Destroy; +end; + +function TColumnComboBoxEx.ColumnMarginStored: Boolean; +begin + Result := FColumnMargin <> Scale96ToFont(DEFAULT_COLUMN_MARGIN); +end; + +procedure TColumnComboBoxEx.DoAutoAdjustLayout( + const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double + ); +begin + inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion); + + if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then + begin + if ColumnMarginStored then + FColumnMargin := Round(FColumnMargin * AXProportion); + Invalidate; + end; +end; + +procedure TColumnComboBoxEx.DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); +var + i, y, xl: Integer; + txt: String; +begin + if Index < 0 then + txt := '' + else + txt := Items[Index]; + + FParser.StrictDelimiter := FDelimiter <> ' '; + FParser.Delimiter := FDelimiter; + FParser.DelimitedText := txt; + + if (odSelected in State) then + Canvas.Brush.Color := clHighlight + else if (Canvas.Brush.Color <> Color) then + Canvas.Brush.Color := Color; + Canvas.FillRect(ARect); + + y := ARect.Top + (ARect.Height - FTextHeight) shr 1; + + if Assigned(FOffsets) then + begin + for i := 0 to FParser.Count-1 do + begin + xl := ARect.Left + FOffsets[i]; + Canvas.TextOut(xl, y, FParser[i]); + end; + if FShowColSeparators then + begin + Canvas.Pen.Color := FColSeparatorColor; + for i := 1 to High(FOffsets) do + begin + xl := FOffsets[i]; + Dec(xl, FColumnMargin); + Canvas.Line(xl, ARect.Top, xl, ARect.Bottom); + end; + end; + end + else + Canvas.TextOut(xl, y, txt); +end; + + +procedure TColumnComboBoxEx.FontChanged(Sender: TObject); +begin + inherited FontChanged(Sender); + FTextHeight := Canvas.TextHeight('ŢÜ'); +end; + +function TColumnComboBoxEx.GetColumnCount: Integer; +var + i, tmp: Integer; + s: String; + + function GetDelimCount: Integer; + var + p: Integer; + begin + Result := 0; + for p := 1 to Length(s) do + if s[p] = FDelimiter then + Inc(Result); + end; + +begin + Result := 0; + for i := 0 to Items.Count-1 do + begin + s := Items[i]; + tmp := GetDelimCount; + if Result < tmp then + Result := tmp; + end; + Inc(Result); +end; + +class function TColumnComboBoxEx.GetControlClassDefaultSize: TSize; +begin + Result := inherited GetControlClassDefaultSize; + Result.cx := 200; +end; + +function TColumnComboBoxEx.GetDelimiteds(const aLine: String): TStringArray; +var + p, start, resultIdx: Integer; +begin + Result := Nil; + SetLength(Result, FColumnCount); + start := 1; + resultIdx := 0; + for p := 1 to Length(aLine) do + begin + case (aLine[p] = FDelimiter) of + True: begin + Result[resultIdx] := Copy(aLine, start, p - start); + start := Succ(p); + Inc(resultIdx); + end; + False: ; + end; + end; + Result[resultIdx] := Copy(aLine, start, Length(aLine)); +end; + +procedure TColumnComboBoxEx.GetItems; +begin + inherited GetItems; + SetOffsets; +end; + +function TColumnComboBoxEx.GetTextSize(const aText: String): TSize; +var + drawFlags: LongWord = DT_CALCRECT or DT_NOPREFIX or DT_SINGLELINE; + r: TRect; + dc: HDC; +begin + r.Left := 0; + r.Top := 0; + dc := GetDC(GetParentForm(Self).Handle); + try + r.Right := 1000; + r.Bottom := 100; + DrawText(dc, PChar(aText), Length(aText), r, drawFlags); + if r.Right = 1000 then + r.Right := 0; + if r.Bottom = 100 then + r.Bottom := 0; + Result.Create(r.Width, r.Height); + finally + ReleaseDC(Parent.Handle, dc); + end; +end; + +procedure TColumnComboBoxEx.SetColSeparatorColor(AValue: TColor); +begin + if FColSeparatorColor <> AValue then + begin + FColSeparatorColor := AValue; + Invalidate; + end; +end; + +procedure TColumnComboBoxEx.SetColumnMargin(aValue: Integer); +begin + if FColumnMargin <> aValue then + begin + FColumnMargin := aValue; + Invalidate; + end; +end; + +procedure TColumnComboBoxEx.SetDelimiter(aValue: AnsiChar); +begin + if FDelimiter <> aValue then + begin + FDelimiter := aValue; + FColumnCount := GetColumnCount; + end; +end; + +procedure TColumnComboBoxEx.SetItems(const Value: TStrings); +begin + inherited SetItems(Value); + SetOffsets; +end; + +procedure TColumnComboBoxEx.SetOffsets; +var + widths: TIntegerDynArray; + i, j: Integer; + sa: TStringArray; + sz: TSize; +begin + if not Assigned(Parent) or (Items.Count = 0) then + Exit; + FColumnCount := GetColumnCount; + + SetLength({%H-}widths, FColumnCount); + for i := 0 to Items.Count-1 do + begin + sa := GetDelimiteds(Items[i]); + FTextHeight := GetTextSize('ŢÜ').cy; + for j := 0 to High(sa) do + begin + sz := GetTextSize(sa[j]); + if widths[j] < sz.cx then + widths[j] := sz.cx; + end; + end; + SetLength(FOffsets, FColumnCount); + for j := 0 to High(FOffsets) do + case j of + 0: FOffsets[j] := FColumnMargin; + else + FOffsets[j] := FOffsets[Pred(j)] + widths[Pred(j)] + FColumnMargin shl 1; + end; +end; + +procedure TColumnComboBoxEx.SetShowColSeparators(aValue: Boolean); +begin + if FShowColSeparators <> aValue then + begin + FShowColSeparators := aValue; + Invalidate; + end; +end; + +procedure TColumnComboBoxEx.SetStyle(AValue: TComboBoxStyle); +begin + if (AValue in [csSimple, csDropDown, csDropDownList]) then + raise Exception.Create('Only owner-draw styles allowed.'); + + inherited SetStyle(AValue); +end; + +end. + diff --git a/components/exctrls/source/exctrlsreg.pas b/components/exctrls/source/exctrlsreg.pas index 7677337aa..2dba6b81d 100644 --- a/components/exctrls/source/exctrlsreg.pas +++ b/components/exctrls/source/exctrlsreg.pas @@ -12,7 +12,7 @@ procedure Register; implementation uses - ExButtons, ExCheckCtrls, ExEditCtrls; + ExButtons, ExCheckCtrls, ExEditCtrls, ExCombo; {$R exctrlsreg.res} @@ -20,7 +20,8 @@ procedure Register; begin RegisterComponents('ExCtrls', [ TButtonEx, TCheckboxEx, TRadioButtonEx, TCheckGroupEx, TRadioGroupEx, - TFloatSISpinEditEx, TCurrSpinEditEx + TFloatSISpinEditEx, TCurrSpinEditEx, + TColumnComboBoxEx ]); end; diff --git a/components/exctrls/source/exctrlsreg.res b/components/exctrls/source/exctrlsreg.res index 7bc6fc677..f7980e2c0 100644 Binary files a/components/exctrls/source/exctrlsreg.res and b/components/exctrls/source/exctrlsreg.res differ