Multi Column ListBox with Column Sorting and Resizing

Problem/Question/Abstract:

How to make Multi Column ListBox with Column Sorting and Resizing

Answer:

This is a VCL that allows multiple columns in a list box. The columns may be sorted (if the AllowSorting property is set to true) by clicking on the column header title. The column headers are set up in the Sections property. They are of type THeaderSections from the THeader component and thus may also display images from an associated image list. The items in the ListBox are semi-colon delimited fields. The fields are lined up in accordance to the Section headers and may be resized by the user at run-time.

eg.
MultiColListBox.Items.Add('John Smith;jsmith@eoh.co.za');

The fields within the item line may be retrieved individually using overloaded methods GetField() and the field index required (0 based) or the Item Index. The fields within the item line can also be set via the SetField() method.

eg.
MultiColListBox.GetField(MultiColListBox.Items[1],1) or
MultiColListBox.GetField(12,3)

Section Headers may be added and deleted programatically at run time. Use the Invalidate or Update method to realign the columns and reset the Section Event triggers afterwards.

eg.
MultiColListBox.Sections.Delete(1);
MultiColListBox.Invalidate;  // Realign columns

I have one problem at design time in that I cannot find a way to call FListBox.Invalidate after the Sections property has been modified to realign the columns. There is no problem at run-time though. If anyone has a solution I would be grateful.

(I have tried to apply a SetFSections method as in
property Sections : THeaderSections read FSections write SetFSections;
but the write call does not seem to get called at all)

unit MultiColListbox;
interface

uses Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, ComCtrls,
  StdCtrls, Graphicsl;

type
  TOnContextPopup = procedure(Sender: TObject; MousePos: TPoint;
    var Handled: boolean) of object;

  TOnKeyDownUp = procedure(Sender: TObject; var Key: word;
    Shift: TShiftState) of object;

  TOnMouseDownUp = procedure(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: integer) of object;

  TOnMouseMove = procedure(Sender: TObject; Shift: TShiftState;
    X, Y: integer) of object;

  TOnKeyPress = procedure(Sender: TObject; var Key: char) of object;

  TMultiColListbox = class(TCustomPanel)
  private
    // Event Hooks
    FDelimiter: char;
    FOnMouseMove: TOnMouseMove;
    FOnMouseDown,
      FOnMouseUp: TOnMouseDownUp;
    FOnKeyPress: TOnKeyPress;
    FOnKeyUp,
      FOnKeyDown: TOnKeyDownUp;
    FOnContextPopup: TOnContextPopup;
    FOnEnter,
      FOnExit,
      FOnDblClick,
      FOnClick: TNotifyEvent;
    // Property Fields
    FCurrCol: integer;
    FAllowSorting: boolean;
    FHeaderFont,
      FFont: TFont;
    FItems: TStrings;
    FSections: THeaderSections;
    FHeader: THeaderControl;
    FListBox: TListBox;

    // Get-Set Property Methods
    procedure SetFItems(Value: TStrings);
    procedure SetFFont(Value: TFont);
    procedure SetFHeaderFont(Value: TFont);
    procedure SetFColor(Value: TColor);
    function GetFColor: TColor;
    procedure SetFExtendedSelect(Value: boolean);
    function GetFExtendedSelect: boolean;
    procedure SetFIntegralHeight(Value: boolean);
    function GetFIntegralHeight: boolean;
    procedure SetFMultiSelect(Value: boolean);
    function GetFMultiSelect: boolean;
    function GetFColCount: integer;
    function GetFSelCount: integer;
    function GetFSelected(Index: integer): boolean;
    procedure SetFSelected(Index: integer; Value: boolean);
    function GetFItemIndex: integer;
    procedure SetFItemIndex(Value: integer);
    procedure SetFHeaderHeight(Value: integer);
    function GetFHeaderHeight: integer;
    procedure SetFHeaderImages(Value: TImageList);
    function GetFHeaderImages: TImageList;
    procedure SetFAllowSorting(Value: boolean);
    procedure SetSectionEvents;

    // FListBox Event Hook Mapping
    procedure PDoClick(Sender: TObject);
    procedure PDoDblClick(Sender: TObject);
    procedure PDoEnter(Sender: TObject);
    procedure PDoExit(Sender: TObject);
    procedure PDoContextPopup(Sender: TObject; MousePos: TPoint;
      var Handled: boolean);
    procedure PDoKeyDown(Sender: TObject; var Key: word;
      Shift: TShiftState);
    procedure PDoKeyUp(Sender: TObject; var Key: word;
      Shift: TShiftState);
    procedure PDoKeyPress(Sender: TObject; var Key: char);
    procedure PDoMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: integer);
    procedure PDoMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: integer);
    procedure PDoMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: integer);
  protected
    // Internal Calls
    procedure ListBoxDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure SectionResize(HeaderControl: THeaderControl;
      Section: THeaderSection);
    procedure HeaderResize(Sender: TObject);
    procedure SectionClick(HeaderControl: THeaderControl;
      Section: THeaderSection);
    function XtractField(var Source: string): string;
    procedure QuickSort(Lo, Hi: integer; CC: TStrings);
    procedure Loaded; override;
  public
    { Public declarations }
    // TCustomPanel Virtual Method Overrides
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Invalidate; override;
    procedure Update; override;
    procedure SetFocus; override;

    procedure Sort;
    function GetField(const Line: string; FieldIndex: integer): string; overload;
    function GetField(LineIndex, FieldIndex: integer): string; overload;
    procedure SetField(const NewValue: string;
      LineIndex, FieldIndex: integer);
    property ColCount: integer read GetFColCount;
    property SelCount: integer read GetFSelCount;
    property Selected[Index: integer]: boolean read GetFSelected
    write SetFSelected;
    property ItemIndex: integer read GetFItemIndex write SetFItemIndex;
  published
    // THeader Properties
    property Sections: THeaderSections read FSections write FSections;
    property HeaderFont: TFont read FHeaderFont write SetFHeaderFont;
    property HeaderHeight: integer read GetFHeaderHeight
      write SetFHeaderHeight;
    property HeaderImages: TImageList read GetFHeaderImages
      write SetFHeaderImages;

    // TListBox Properties
    property Delimiter: char read FDelimiter write FDelimiter;
    property Items: TStrings read FItems write SetFItems;
    property Font: TFont read FFont write SetFFont;
    property Color: TColor read GetFColor write SetFColor;
    property ExtendedSelect: boolean read GetFExtendedSelect
      write SetFExtendedSelect;
    property IntegralHeight: boolean read GetFIntegralHeight
      write SetFIntegralHeight;
    property MultiSelect: boolean read GetFMultiSelect
      write SetFMultiSelect;
    property AllowSorting: boolean read FAllowSorting
      write SetFAllowSorting;

    // TListBox Events
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnContextPopup: TOnContextPopup read FOnContextPopup
      write FOnContextPopup;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
    property OnKeyDown: TOnKeyDownUp read FOnKeyDown write FOnKeyDown;
    property OnKeyUp: TOnKeyDownUp read FOnKeyUp write FOnKeyUp;
    property OnKeyPress: TOnKeyPress read FOnKeyPress write FOnKeyPress;
    property OnMouseDown: TOnMouseDownUp read FOnMouseDown
      write FOnMouseDown;
    property OnMouseUp: TOnMouseDownUp read FOnMouseUp write FOnMouseUp;
    property OnMouseMove: TOnMouseMove read FOnMouseMove write FOnMouseMove;

    // Expose required parent properties
    property Align;
    property Anchors;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BorderStyle;
    property BorderWidth;
    property Constraints;
    property Enabled;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
  end;

procedure Register;

// -------------------------------------------------------------------------
implementation

procedure Register;
begin
  RegisterComponents('MahExtra', [TMultiColListbox]);
end;

// ===================================
// Return Count of a char in a string
// ===================================

function CharCount(SearchChar: char; Buffer: string): integer;
var
  C, i: integer;
begin
  C := 0;
  if length(Buffer) > 0 then
    for i := 1 to length(Buffer) do
      if Buffer[i] = SearchChar then
        inc(C);
  Result := C;
end;

constructor TMultiColListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 200;
  Height := 110;
  Caption := '';
  BevelOuter := bvNone;
  FAllowSorting := false;
  FCurrCol := 0;
  FDelimiter := ';';

  // THeaderSection
  FHeader := THeaderControl.Create(self);
  FHeader.Parent := self;
  FSections := FHeader.Sections;
  FHeaderFont := FHeader.Font;

  // TListBox
  FListBox := TListBox.Create(self);
  FListBox.Parent := self;
  FListBox.Align := alClient;
  FListBox.Style := lbOwnerDrawFixed;
  FListBox.OnDrawItem := ListBoxDrawItem;
  FListBox.OnClick := PDoClick;
  FListBox.OnDblClick := PDoDblClick;
  FListBox.OnContextPopup := PDoContextPopup;
  FListBox.OnEnter := PDoEnter;
  FListBox.OnExit := PDoExit;
  FListBox.OnKeyDown := PDoKeyDown;
  FListBox.OnKeyUp := PDoKeyUp;
  FListBox.OnKeyPress := PDoKeyPress;
  FListBox.OnMouseDown := PDoMouseDown;
  FListBox.OnMouseUp := PDoMouseUp;
  FListBox.OnMouseMove := PDoMouseMove;
  FItems := FListBox.Items;
  FFont := FListBox.Font;
end;

destructor TMultiColListBox.Destroy;
begin
  FHeader.Free;
  FListBox.Free;
  inherited Destroy;
end;

procedure TMultiColListBox.Loaded;
begin
  inherited Loaded;
  SetSectionEvents;
  if FAllowSorting and
    (FListBox.Items.Count > 0) then
    QuickSort(0, FListBox.Items.Count - 1, FListBox.Items);
end;

procedure TMultiColListBox.SetFocus;
begin
  inherited SetFocus;
  FListBox.SetFocus;
end;

// =================================================================
// If Component Invalidate or Update methods are called
// then reassign any THeaderSections events and repaint ListBox
// =================================================================

procedure TMultiColListBox.Invalidate;
begin
  inherited Invalidate;
  if not (csDesigning in ComponentState) and
    (FListBox <> nil) then
  begin
    SetSectionEvents;
    FListBox.Invalidate;
  end;
end;

procedure TMultiColListBox.Update;
begin
  inherited Update;
  if not (csDesigning in ComponentState) and
    (FListBox <> nil) then
  begin
    SetSectionEvents;
    FListBox.Invalidate;
  end;
end;

// =====================================================================
// Assign OnClick etc. Event Handlers to ALL created THeaderSections
// =====================================================================

procedure TMultiColListBox.SetSectionEvents;
var
  i: integer;
begin
  if not (csDesigning in ComponentState) then
  begin
    FHeader.OnSectionResize := SectionResize;
    FHeader.OnResize := HeaderResize;
    FHeader.OnSectionClick := SectionClick;
    for i := 0 to FHeader.Sections.Count - 1 do
      FHeader.Sections.Items[i].AllowClick := FAllowSorting;
  end;
end;

// =========================================================================
// Return the field denoted by Index from line of ";" delimited item string
// =========================================================================

function TMultiColListBox.GetField(const Line: string;
  FieldIndex: integer): string;
var
  i: integer;
  S, L: string;
begin
  L := Line;
  for i := 0 to FieldIndex do
    S := XTractField(L);
  Result := S;
end;

function TMultiColListBox.GetField(LineIndex, FieldIndex: integer): string;
var
  Retvar: string;
begin
  Retvar := '';
  LineIndex := abs(LineIndex);

  if (Items.Count > 0) and (LineIndex <= Items.Count - 1) then
  begin
    Retvar := GetField(Items[LineIndex], FieldIndex);
  end;

  Result := Retvar;
end;

// =========================================================================
// Set the field denoted by Index to new value
// =========================================================================

procedure TMultiColListBox.SetField(const NewValue: string;
  LineIndex, FieldIndex: integer);
var
  i, DCount: integer;
  S, L: string;
begin
  LineIndex := abs(LineIndex);

  if (Items.Count > 0) and (LineIndex <= Items.Count - 1) then
  begin
    S := '';
    L := Items[LineIndex];
    DCount := CharCount(FDelimiter, L);

    for i := 0 to DCount do
    begin
      if i = FieldIndex then
        S := S + NewValue
      else
        S := S + XTractField(L);

      if i < DCount then
        S := S + FDelimiter;
    end;

    Items[LineIndex] := S;
  end;
end;

// ==============================================
// INTERNAL CALL
// General Recursive quick sort routine.
// ==============================================

procedure TMultiColListBox.QuickSort(Lo, Hi: integer; CC: TStrings);

  procedure sort(l, r: integer);
  var
    i, j: integer;
    x, Tmp: string;
  begin
    i := l;
    j := r;
    x := GetField(CC[(l + r) div 2], FCurrCol);
    repeat
      while GetField(CC[i], FCurrCol) < x do
        inc(i);
      while x < GetField(CC[j], FCurrCol) do
        dec(j);
      if i <= j then
      begin
        Tmp := CC[j];
        CC[j] := CC[i];
        CC[i] := Tmp;
        inc(i);
        dec(j);
      end;
    until i > j;
    if l < j then
      sort(l, j);
    if i < r then
      sort(i, r);
  end;

begin
  CC.BeginUpdate;
  sort(Lo, Hi);
  CC.EndUpdate;
end;

// =============================================================
// INTERNAL CALL
// Extracts a field from a string delimited by ";"
// The source string is returned with the field and ";" removed
// =============================================================

function TMultiColListBox.XtractField(var Source: string): string;
var
  Retvar: string;
  L, P: integer;
begin
  P := pos(FDelimiter, Source);

  if P = 0 then
  begin
    RetVar := Source;
    Source := '';
  end
  else
  begin
    RetVar := '';
    L := length(Source);
    RetVar := copy(Source, 1, P - 1);
    L := L - (length(RetVar) + 1);
    Source := copy(Source, P + 1, L);
  end;

  Result := Retvar;
end;

// =====================================================
// ListBox OWNERDRAW routine.
// Draw the columns lined up with header control
// =====================================================

procedure TMultiColListBox.ListBoxDrawItem(Control: TWinControl;
  Index: Integer;
  Rect: TRect;
  State: TOwnerDrawState);
var
  Line: string;
  LB: TListBox;
  i: integer;
begin
  LB := (Control as TListBox);
  Line := LB.Items[Index];
  LB.Canvas.FillRect(Rect);

  if FHeader.Sections.Count = 0 then
  begin
    // No Header Sections Defined - Display raw ";" delimited
    for i := 1 to length(Line) do
      if Line[i] = FDelimiter then
        Line[i] := ' ';
    LB.Canvas.TextOut(Rect.Left + 2, Rect.Top, Line);
  end
  else
  begin
    // Align ";" delimited fields to Header Sections
    for i := 0 to FHeader.Sections.Count - 1 do
    begin
      LB.Canvas.TextOut(Rect.Left + FHeader.Sections.Items[i].Left + 2,
        Rect.Top, XTractField(Line));
    end;
  end;
end;

// ================================
// Sort the items on column 0
// ================================

procedure TMultiColListBox.Sort;
begin
  FListBox.Sorted := true;
  FListBox.Sorted := false;
end;

// ===============================
// THeaderSections Events
// ===============================

procedure TMultiColListBox.SectionResize(HeaderControl: THeaderControl;
  Section: THeaderSection);
begin
  HeaderResize(nil);
end;

procedure TMultiColListBox.HeaderResize(Sender: TObject);
begin
  FListBox.InValidate;
end;

procedure TMultiColListBox.SectionClick(HeaderControl: THeaderControl;
  Section: THeaderSection);
begin
  FCurrCol := Section.Index;
  QuickSort(0, FListBox.Items.Count - 1, FListBox.Items);
  FListBox.SetFocus;
end;

// =============================================================================
// TListBox user Event Handlers - call user action if assigned
// =============================================================================

procedure TMultiColListBox.PDoClick(Sender: TObject);
begin
  if Assigned(FOnClick) then
    FOnClick(self);
end;

procedure TMultiColListBox.PDoDblClick(Sender: TObject);
begin
  if Assigned(FOnDblClick) then
    FOnDblClick(self);
end;

procedure TMultiColListBox.PDoContextPopup(Sender: TObject;
  MousePos: TPoint;
  var Handled: Boolean);
begin
  if Assigned(FOnContextPopup) then
    FOnContextPopup(self, MousePos, Handled);
end;

procedure TMultiColListBox.PDoEnter(Sender: TObject);
begin
  if Assigned(FOnEnter) then
    FOnEnter(self);
end;

procedure TMultiColListBox.PDoExit(Sender: TObject);
begin
  if Assigned(FOnExit) then
    FOnExit(self);
end;

procedure TMultiColListBox.PDoKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Assigned(FOnKeyDown) then
    FOnKeyDown(self, Key, Shift);
end;

procedure TMultiColListBox.PDoKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Assigned(FOnKeyUp) then
    FOnKeyUp(self, Key, Shift);
end;

procedure TMultiColListBox.PDoKeyPress(Sender: TObject; var Key: char);
begin
  if Assigned(FOnKeyPress) then
    FOnKeyPress(self, Key);
end;

procedure TMultiColListBox.PDoMouseDown(Sender: TObject;
  Button: TMouseButton;
  Shift: TShiftState; X, Y: integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(self, Button, Shift, X, Y);
end;

procedure TMultiColListBox.PDoMouseUp(Sender: TObject;
  Button: TMouseButton;
  Shift: TShiftState; X, Y: integer);
begin
  if Assigned(FOnMouseUp) then
    FOnMouseUp(self, Button, Shift, X, Y);
end;

procedure TMultiColListBox.PDoMouseMove(Sender: TObject;
  Shift: TShiftState;
  X, Y: integer);
begin
  if Assigned(FOnMouseMove) then
    FOnMouseMove(self, Shift, X, Y);
end;

// =========================================================================
// GET/SET Property Methods
// =========================================================================

procedure TMultiColListBox.SetFItems(Value: TStrings);
begin
  FItems.Assign(Value);
end;

procedure TMultiColListBox.SetFFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TMultiColListBox.SetFHeaderFont(Value: TFont);
begin
  FHeaderFont.Assign(Value);
end;

procedure TMultiColListBox.SetFColor(Value: TColor);
begin
  FListBox.Color := Value;
end;

function TMultiColListBox.GetFColor: TColor;
begin
  Result := FListBox.Color;
end;

procedure TMultiColListBox.SetFExtendedSelect(Value: boolean);
begin
  FListBox.ExtendedSelect := Value;
end;

function TMultiColListBox.GetFExtendedSelect: boolean;
begin
  Result := FListBox.ExtendedSelect;
end;

procedure TMultiColListBox.SetFIntegralHeight(Value: boolean);
begin
  FListBox.IntegralHeight := Value;
end;

function TMultiColListBox.GetFIntegralHeight: boolean;
begin
  Result := FListBox.IntegralHeight;
end;

procedure TMultiColListBox.SetFMultiSelect(Value: boolean);
begin
  FListBox.MultiSelect := Value;
end;

function TMultiColListBox.GetFMultiSelect: boolean;
begin
  Result := FListBox.MultiSelect;
end;

function TMultiColListBox.GetFColCount: integer;
begin
  Result := FHeader.Sections.Count;
end;

function TMultiColListBox.GetFSelCount: integer;
begin
  Result := FListBox.SelCount;
end;

function TMultiColListBox.GetFSelected(Index: integer): boolean;
begin
  Result := FListBox.Selected[Index];
end;

procedure TMultiColListBox.SetFSelected(Index: integer; Value: boolean);
begin
  FListBox.Selected[Index] := Value;
end;

function TMultiColListBox.GetFItemIndex: integer;
begin
  Result := FListBox.ItemIndex;
end;

procedure TMultiColListBox.SetFItemIndex(Value: integer);
begin
  FListBox.ItemIndex := Value;
end;

procedure TMultiColListBox.SetFAllowSorting(Value: boolean);
begin
  FAllowSorting := Value;
  if not (csDesigning in ComponentState) then
    SetSectionEvents;
  if FAllowSorting and
    (FListBox.Items.Count > 0) then
    QuickSort(0, FListBox.Items.Count - 1, FListBox.Items);
end;

procedure TMultiColListBox.SetFHeaderHeight(Value: integer);
begin
  FHeader.Height := Value;
end;

function TMultiColListBox.GetFHeaderHeight: integer;
begin
  Result := FHeader.Height;
end;

procedure TMultiColListBox.SetFHeaderImages(Value: TImageList);
begin
  FHeader.Images := Value;
end;

function TMultiColListBox.GetFHeaderImages: TImageList;
begin
  Result := TImageList(FHeader.Images);
end;

{EOF}
end.