ExCtrls: Initial commit of TColumnComboBoxEx by Howard Page-Clark.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7938 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/exctrls/exctrlspkg.lpk

@@ -15,9 +15,10 @@
     </CompilerOptions>
     <Description Value="Extended standard controls: 
 - CurrencyEdit, FloatSIEdit (supports SI units suffixes)
-- TRadioButton, TCheckbox, TRadioGroup and TCheckGroup: drawn by ThemeServices/Canvas, not by widgetset, button/text layout, wordwrap, user-provided check images"/>
+- TRadioButton, TCheckbox, TRadioGroup and TCheckGroup: drawn by ThemeServices/Canvas, not by widgetset, button/text layout, wordwrap, user-provided check images
+- TColumnComboBoxEx"/>
     <License Value="LGPL with linking exception (like Lazarus LCL)."/>
-    <Files Count="4">
+    <Files Count="5">
       <Item1>
         <Filename Value="source\excheckctrls.pas"/>
         <UnitName Value="ExCheckCtrls"/>
@@ -35,6 +36,10 @@
         <Filename Value="source\exbuttons.pas"/>
         <UnitName Value="ExButtons"/>
       </Item4>
+      <Item5>
+        <Filename Value="source\excombo.pas"/>
+        <UnitName Value="ExCombo"/>
+      </Item5>
     </Files>
     <CompatibilityMode Value="True"/>
     <RequiredPkgs Count="2">

components/exctrls/exctrlspkg.pas

@@ -8,7 +8,7 @@ unit ExCtrlsPkg;
 interface
 
 uses
-  ExCheckCtrls, ExEditCtrls, ExCtrlsReg, ExButtons, LazarusPackageIntf;
+  ExCheckCtrls, ExEditCtrls, ExCtrlsReg, ExButtons, ExCombo, LazarusPackageIntf;
 
 implementation
 

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

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

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;