lazarus-ccr/components/exctrls/source/excombo.pas

{ 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;
    FSelectedColor: TColor;
    FSelectedTextColor: TColor;
    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);
    procedure SetSelectedColor(AValue: TColor);
    procedure SetSelectedTextColor(AValue: TColor);
  protected
    procedure CreateHandle; override;
    procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
      const AXProportion, AYProportion: Double); override;
    procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); override;
    class function GetControlClassDefaultSize: TSize; override;
    procedure GetItems; override;
    procedure InitializeWnd; 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 SelectedColor: TColor read FSelectedColor write SetSelectedColor default clHighlight;
    property SelectedTextColor: TColor read FSelectedTextColor write SetSelectedTextColor default clHighlightText;
    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;
  FSelectedColor := clHighlight;
  FSelectedTextColor := clHighlightText;
  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.CreateHandle;
begin
  inherited;
  SetOffsets;
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;
  savedColor, savedFontColor: TColor;
begin
  if Assigned(OnDrawItem) then
  begin
    OnDrawItem(Self, Index, ARect, State);
    exit;
  end;

  savedColor := Canvas.Brush.Color;
  savedFontColor := Canvas.Font.Color;

  if DroppedDown then
  begin
    if (odSelected in State) then
    begin
      Canvas.Brush.Color := FSelectedColor;
      Canvas.Font.Color := FSelectedTextColor;
    end else
    if (Canvas.Brush.Color <> Color) then
      Canvas.Brush.Color := Color;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(ARect);
  end else
    Canvas.Font.Color := clWindowText;

  if Index < 0 then
    txt := ''
  else
    txt := Items[Index];

  FParser.StrictDelimiter := FDelimiter <> ' ';
  FParser.Delimiter := FDelimiter;
  FParser.DelimitedText := txt;

  y := ARect.Top + (ARect.Height - FTextHeight) shr 1;
  Canvas.Brush.Style := bsClear;  // transparent text background
  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);

  Canvas.Brush.Color := savedColor;
  Canvas.Font.Color := savedFontColor;
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.InitializeWnd;
begin
  inherited;
  SetOffsets;
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.SetSelectedColor(AValue: TColor);
begin
  if FSelectedColor <> AValue then
  begin
    FSelectedColor := AValue;
    Invalidate;
  end;
end;

procedure TColumnComboBoxEx.SetSelectedTextColor(AValue: TColor);
begin
  if FSelectedTextColor <> AValue then
  begin
    FSelectedTextColor := AValue;
    Invalidate;
  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.