See:
unit BackHeadList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, Menus;
type
THLBDrawCellEvent = procedure(Control: TWinControl; Index, Col: Integer;
Rect: TRect; State: TOwnerDrawState) of object;
THLBStyle = (hlbStandard, hlbOwnerDraw);
TBackHeaderListbox = class(TWinControl)
private
FBackMap: TBitMap;
FBackOn: Boolean;
FHeader: THeaderControl;
FListbox: TListbox;
FDelimChar: Char;
FLBStyle: THLBStyle;
FPopupMenu: TPopupMenu;
FOnDrawCell: THLBDrawCellEvent;
FOnClick: TNotifyEvent;
FOnDblClick: TNotifyEvent;
FOnMouseDown: TMouseEvent;
FOnMouseUp: TMouseEvent;
FOnMouseMove: TMouseMoveEvent;
LastPoint: integer;
function MakeLocalPoint(Control: TControl; X, Y: integer): TPoint;
// event handlers for header and listbox events
procedure DrawTrackingLine(HeaderControl: THeaderControl;
Section: THeaderSection; Width: Integer; State: TSectionTrackState);
procedure DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
State: TOwnerDrawState);
procedure FClick(Sender: TObject);
procedure FDblClick(Sender: TObject);
procedure FMouseDown(Sender: TObject; Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
procedure FMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
procedure FMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
// Get/Set methods for header properties
function GetSections: THeaderSections;
procedure SetSections(Value: THeaderSections);
// Get/Set methods for listbox properties
function GetItems: TStrings;
procedure SetItems(Value: TStrings);
function GetExtSel: Boolean;
procedure SetExtSel(Value: Boolean);
function GetMultiSel: Boolean;
procedure SetMultiSel(Value: Boolean);
function GetItemHeight: integer;
procedure SetItemHeight(Value: integer);
function GetItemIndex: integer;
procedure SetItemIndex(Value: integer);
function GetIntHeight: Boolean;
procedure SetIntHeight(Value: Boolean);
function GetSelected(Index: integer): Boolean;
procedure SetSelected(Index: integer; Value: Boolean);
function GetSorted: Boolean;
procedure SetSorted(Value: Boolean);
function GetSelCount: integer;
function GetTopIndex: integer;
procedure SetTopIndex(Value: integer);
// Get/Set methods for new properties
function GetLBCanvas: TCanvas;
function GetHeaderCanvas: TCanvas;
function GetLBHandle: hWnd;
function GetHeaderHandle: hWnd;
// my do Get/Set methods for new properties
function GetHeaderHeight: integer;
procedure SetHeaderHeight(Value: integer);
//set/get fheader style
function GetHeaderStyle: THeaderStyle;
procedure SetHeaderStyle(Value: THeaderStyle);
procedure SetDelimChar(Value: Char);
procedure SetLBStyle(Value: THLBStyle);
procedure SetPopupMenu(Value: TPopupMenu);
procedure SetBackMap(Value: TBitMap);
procedure SetBackOn(Value: Boolean);
protected
property Hint;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// New properties
property LBCanvas: TCanvas read GetLBCanvas;
property HeaderCanvas: TCanvas read GetHeaderCanvas;
property LBHandle: hWnd read GetLBHandle;
property HeaderHandle: hWnd read GetHeaderHandle;
// TListbox public (runtime) properties
property SelCount: integer read GetSelCount;
property Selected[Index: Integer]: Boolean read GetSelected
write SetSelected;
property TopIndex: Integer read GetTopIndex write SetTopIndex;
function GetItemsString(ItemIndex,StringIndex: Integer): String;
published
// TWinControl properties
property Align;
property Color;
property Font;
property ParentFont;
property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
// TListbox properties
property ExtendedSelect: Boolean read GetExtSel write SetExtSel;
property IntegralHeight: Boolean read GetIntHeight write SetIntHeight;
property ItemHeight: integer read GetItemHeight write SetItemHeight;
property ItemIndex: integer read GetItemIndex write SetItemIndex;
property Items: TStrings read GetItems write SetItems;
property MultiSelect: Boolean read GetMultiSel write SetMultiSel;
property Sorted: Boolean read GetSorted write SetSorted;
// THeaderControl properties
property Sections: THeaderSections read GetSections write SetSections;
// My do, new properties
property HeaderHeight: integer read GetHeaderHeight write SetHeaderHeight;
property HeaderStyle: THeaderStyle read GetHeaderStyle write SetHeaderStyle;
// New properties
property DelimChar: Char read FDelimChar write SetDelimChar;
property LBStyle: THLBStyle read FLBStyle write SetLBStyle;
property OnDrawCell: THLBDrawCellEvent read FOnDrawCell write FOnDrawCell;
property BackMap: TBitMap read FBackMap write SetBackMap;
property BackOn: Boolean read FBackOn write SetBackOn default False;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('sarcon', [TBackHeaderListbox]);
end;
constructor TBackHeaderListbox.Create(AOwner: TComponent);
begin
inherited Create(AOwner); // call inherited
ControlStyle := ControlStyle - [csSetCaption]; // no caption
Width := 150; // set bounds
Height := 100;
FDelimChar := #32;
FHeader := THeaderControl.Create(Self); // create header
with FHeader do begin // set header props
Parent := Self;
Align := alTop;
FHeader.Height := 22;
OnSectionTrack := DrawTrackingLine; // hook header events
OnMouseDown := FMouseDown;
OnMouseUp := FMouseUp;
OnMouseMove := FMouseMove;
end;
FListbox := TListbox.Create(Self); // create listbox
with FListbox do begin // set listbox props
Parent := Self;
Align := alClient;
ParentColor := True;
Style := lbOwnerDrawFixed;
OnDrawItem := DrawItem; // hook listbox events
OnClick := FClick;
OnDblClick := FDblClick;
OnMouseDown := FMouseDown;
OnMouseUp := FMouseUp;
OnMouseMove := FMouseMove;
end;
FBackMap := TBitMap.Create;
end;
destructor TBackHeaderListbox.Destroy;
begin
FHeader.Free; // free header
FListbox.Free; // free listbox
FBackMap.FreeImage;
inherited Destroy; // call inherited
end;
procedure TBackHeaderListbox.SetBackMap(Value: TBitMap);
begin
if Value <>nil then
begin
FBackMap.Assign(Value);
FListbox.Brush.Bitmap := nil;
FListbox.Brush.Bitmap := FBackMap;
end
else
begin
FListbox.Brush.Bitmap := nil;
FBackMap := nil;
end;
end;
procedure TBackHeaderListbox.SetBackOn(Value: Boolean);
begin
if Value then
begin
if FBackMap <> nil then
FListbox.Brush.Bitmap := FBackMap;
FBackOn := Value;
end;
end;
procedure TBackHeaderListbox.DrawTrackingLine(HeaderControl: THeaderControl;
Section: THeaderSection; Width: Integer;
State: TSectionTrackState);
{ OnSectionTrack handler for header. This procedure is called to }
{ draw the tracking line in the listbox as the header is sized. }
begin
with FListbox.Canvas do begin
Pen.Mode := pmNot; // use NOT pen mode
if (LastPoint > 0) then begin // if not first line...
MoveTo(LastPoint, 0);
LineTo(LastPoint, FListbox.ClientHeight); // erase last line
end;
if State <> tsTrackEnd then begin // if still tracking...
MoveTo(Section.Left + Width, 0);
LineTo(Section.Left + Width, FListbox.ClientHeight); // draw new line
LastPoint := Section.Left + Width; // save line position
end
else begin // otherwise...
LastPoint := 0; // reset line position
Invalidate;
end;
end;
end;
function TBackHeaderListbox.GetItemsString(ItemIndex,StringIndex: Integer): String;
var
CurItem: String;
i, CurPos, TmpPos: integer;
begin
if (StringIndex >= FHeader.Sections.Count) then
begin
ShowMessage('StringIndex Out of bounds('+IntToStr(FHeader.Sections.Count)+')');
Exit;
end;
CurItem := Items[ItemIndex];
CurPos := 1;
for i := 0 to StringIndex do begin
TmpPos := Pos(FDelimChar,CurItem);
if (TmpPos > 0) and (CurPos <= Length(CurItem)) then
begin
if (i = StringIndex) then
Result := Copy(CurItem,CurPos,TmpPos-CurPos)
else
begin
CurItem[TmpPos] := Chr(Ord(FDelimChar) + 1);
CurPos := TmpPos + 1;
end;
end
else
if (i = StringIndex) then
Result := Copy(CurItem, CurPos, Length(CurItem)) //返回全值
else //返问的位置没有数据
begin
Result := '';
Exit;
end;
end;
end;
procedure TBackHeaderListbox.DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
i, CurPos: integer;
CurItem: String;
function GetNextStr: String;
{ returns string after next delimter }
var
TmpPos: integer;
begin
TmpPos := Pos(FDelimChar, CurItem);
if (TmpPos > 0) and (CurPos <= Length(CurItem)) then begin
Result := Copy(CurItem, CurPos, TmpPos - CurPos);
CurItem[TmpPos] := Chr(Ord(FDelimChar) + 1);
CurPos := TmpPos + 1;
end
else if TmpPos = 0 then begin
Result := Copy(CurItem, CurPos, Length(CurItem));
CurPos := Length(CurItem) + 1;
end;
end;
const
{ DrawText alignment flags }
Alignment: array[TAlignment] of word = (dt_Left, dt_Right, dt_Center);
begin
CurItem := Items[Index]; // get current index
CurPos := 1;
LBCanvas.FillRect(Rect); // empty draw rect
LBCanvas.Brush.Style := bsClear;
// LbCanvas.Brush.Bitmap := FBackMap;
{ iterate over all sections in header }
for i := 0 to FHeader.Sections.Count - 1 do begin
{ create a draw rect based on header section }
Rect.Left := FHeader.Sections.Left;
Rect.Right := FHeader.Sections.Right;
{ draw into rect next delimted string if standard }
if LBStyle = hlbStandard then
DrawText(LBCanvas.Handle, PChar(GetNextStr), -1, Rect,
dt_SingleLine or dt_VCenter or Alignment[Sections.Alignment])
{ call owner draw event if not standard }
else if Assigned(FOnDrawCell) then
FOnDrawCell(Self, Index, i, Rect, State);
end;
end;
procedure TBackHeaderListbox.FClick(Sender: TObject);
begin
if Assigned(FOnClick) then FOnClick(Self);
end;
procedure TBackHeaderListbox.FDblClick(Sender: TObject);
begin
if Assigned(FOnDblClick) then
FOnDblClick(Self);
end;
function TBackHeaderListbox.MakeLocalPoint(Control: TControl;
X, Y: integer): TPoint;
{ this function takes a coordinate relative to some arbitrary }
{ control and returns a coordinate relative to self }
begin
Result.X := X;
Result.Y := Y;
Result := ScreenToClient(Control.ClientToScreen(Result));
end;
procedure TBackHeaderListbox.FMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{ OnMouseDown handler for header and listbox. Resurfaces event. }
var
Pt: TPoint;
begin
Pt := MakeLocalPoint(Sender as TControl, X, Y);
if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, Pt.X, Pt.Y);
end;
procedure TBackHeaderListbox.FMouseUp(Sender: TObject; Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
{ OnMouseUp handler for header and listbox. Resurfaces event. }
var
Pt: TPoint;
begin
Pt := MakeLocalPoint(Sender as TControl, X, Y);
if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, Pt.X, Pt.Y);
end;
procedure TBackHeaderListbox.FMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
{ OnMouseMove handler for header and listbox. Resurfaces event. }
var
Pt: TPoint;
begin
Pt := MakeLocalPoint(Sender as TControl, X, Y);
if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, Pt.X, Pt.Y);
end;
procedure TBackHeaderListbox.SetDelimChar(Value: Char);
begin
if FDelimChar <> Value then begin
FDelimChar := Value;
Invalidate;
end;
end;
procedure TBackHeaderListbox.SetPopupMenu(Value: TPopupMenu);
begin
FPopupMenu := Value; // set everyone's popup menu
FListbox.PopupMenu := Value;
FHeader.PopupMenu := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
procedure TBackHeaderListbox.SetLBStyle(Value: THLBStyle);
begin
if FLBStyle <> Value then begin
FLBStyle := Value;
Invalidate;
end;
end;
{ What follows are bunches of header and listbox properties which are }
{ resurfaced in the TBackHeaderListbox component. }
function TBackHeaderListbox.GetLBCanvas: TCanvas;
begin
Result := FListbox.Canvas;
end;
function TBackHeaderListbox.GetHeaderCanvas: TCanvas;
begin
Result := FHeader.Canvas;
end;
function TBackHeaderListbox.GetLBHandle: hWnd;
begin
Result := FListbox.Handle;
end;
function TBackHeaderListbox.GetHeaderHandle: hWnd;
begin
Result := FHeader.Handle;
end;
function TBackHeaderListbox.GetItems: TStrings;
begin
Result := FListbox.Items;
end;
procedure TBackHeaderListbox.SetItems(Value: TStrings);
begin
FListbox.Items.Assign(Value);
end;
function TBackHeaderListbox.GetSections: THeaderSections;
begin
Result := FHeader.Sections
end;
procedure TBackHeaderListbox.SetSections(Value: THeaderSections);
begin
FHeader.Sections.Assign(Value);
Invalidate;
end;
//my do
function TBackHeaderListbox.GetHeaderStyle: THeaderStyle;
begin
Result := FHeader.Style;
end;
procedure TBackHeaderListbox.SetHeaderStyle(Value: THeaderStyle);
begin
FHeader.Style := Value;
Invalidate;
end;
//end
function TBackHeaderListbox.GetExtSel: Boolean;
begin
Result := FListbox.ExtendedSelect;
end;
procedure TBackHeaderListbox.SetExtSel(Value: Boolean);
begin
FListbox.ExtendedSelect := Value;
end;
function TBackHeaderListbox.GetMultiSel: Boolean;
begin
Result := FListbox.MultiSelect;
end;
procedure TBackHeaderListbox.SetMultiSel(Value: Boolean);
begin
FListbox.MultiSelect := Value;
end;
function TBackHeaderListbox.GetItemHeight: integer;
begin
Result := FListbox.ItemHeight;
end;
procedure TBackHeaderListbox.SetItemHeight(Value: integer);
begin
FListbox.ItemHeight := Value;
end;
function TBackHeaderListbox.GetItemIndex: integer;
begin
Result := FListbox.ItemIndex;
end;
procedure TBackHeaderListbox.SetItemIndex(Value: integer);
begin
FListbox.ItemIndex := Value;
end;
function TBackHeaderListbox.GetIntHeight: Boolean;
begin
Result := FListbox.IntegralHeight;
end;
procedure TBackHeaderListbox.SetIntHeight(Value: Boolean);
begin
FListbox.IntegralHeight := Value;
end;
// my do Get/Set mothord new properties
function TBackHeaderListbox.GetHeaderHeight: integer;
begin
Result := FHeader.Height;
end;
procedure TBackHeaderListbox.SetHeaderHeight(Value: integer);
begin
FHeader.Height := Value;
end;
// my do end
function TBackHeaderListbox.GetSelected(Index: integer): Boolean;
begin
Result := FListbox.Selected[Index];
end;
怎样才能让继承的Listbox增加滚动条我已经用SendMessage解决了，但怎样让出现
的滚动条能使上面的HeaderControl一起走动呢?
procedure TBackHeaderListbox.SetSelected(Index: integer; Value: Boolean);
begin
FListbox.Selected[Index] := Value;
end;
function TBackHeaderListbox.GetSorted: Boolean;
begin
Result := FListbox.Sorted;
end;
procedure TBackHeaderListbox.SetSorted(Value: Boolean);
begin
FListbox.Sorted := Value;
end;
function TBackHeaderListbox.GetSelCount: integer;
begin
Result := FListbox.SelCount;
end;
function TBackHeaderListbox.GetTopIndex: integer;
begin
Result := FListbox.TopIndex;
end;
procedure TBackHeaderListbox.SetTopIndex(Value: integer);
begin
FListbox.TopIndex := Value;
end;
end.
