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