Mega Code Archive
Multi Column ListBox with Column Sorting and Resizing
<![CDATA[
Title: Multi Column ListBox with Column Sorting and Resizing
Question: 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 method GetField() and the field index required (0 based).
eg.
MultiColListBox.GetField(MultiColListBox.Items[1],1)
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)
Answer:
unit MultiColListbox;
interface
uses Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, ComCtrls,
StdCtrls, Graphics;
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
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;
function GetField(const Line : string; Index : integer) : string;
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 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;
constructor TMultiColListBox.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
Width := 200;
Height := 110;
Caption := '';
BevelOuter := bvNone;
FAllowSorting := false;
FCurrCol := 0;
// 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 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 ";" delim item string
// =======================================================================
function TMultiColListBox.GetField(const Line : string;
Index : integer) : string;
var i : integer;
S,L : string;
begin
L := Line;
for i := 0 to Index do S := XTractField(L);
Result := S;
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) while x if i Tmp := CC[j];
CC[j] := CC[i];
CC[i] := Tmp;
inc(i); dec(j);
end;
until ij;
if l if i end;
begin
sort(Lo,Hi);
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(';',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] = ';' 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;
// ===============================
// 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 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.
]]>