32c8b1cb1c
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2975 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2541 lines
72 KiB
ObjectPascal
2541 lines
72 KiB
ObjectPascal
{*********************************************************}
|
|
{* OVCVLB.PAS 4.06 *}
|
|
{*********************************************************}
|
|
|
|
{* ***** BEGIN LICENSE BLOCK ***** *}
|
|
{* Version: MPL 1.1 *}
|
|
{* *}
|
|
{* The contents of this file are subject to the Mozilla Public License *}
|
|
{* Version 1.1 (the "License"); you may not use this file except in *}
|
|
{* compliance with the License. You may obtain a copy of the License at *}
|
|
{* http://www.mozilla.org/MPL/ *}
|
|
{* *}
|
|
{* Software distributed under the License is distributed on an "AS IS" basis, *}
|
|
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
|
|
{* for the specific language governing rights and limitations under the *}
|
|
{* License. *}
|
|
{* *}
|
|
{* The Original Code is TurboPower Orpheus *}
|
|
{* *}
|
|
{* The Initial Developer of the Original Code is TurboPower Software *}
|
|
{* *}
|
|
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *}
|
|
{* TurboPower Software Inc. All Rights Reserved. *}
|
|
{* *}
|
|
{* Contributor(s): *}
|
|
{* *}
|
|
{* ***** END LICENSE BLOCK ***** *}
|
|
|
|
{$I Ovc.INC}
|
|
|
|
{$B-} {Complete Boolean Evaluation}
|
|
{$I+} {Input/Output-Checking}
|
|
{$P+} {Open Parameters}
|
|
{$T-} {Typed @ Operator}
|
|
{.W-} {Windows Stack Frame}
|
|
{$X+} {Extended Syntax}
|
|
//{$Q-} {Arithmatic-Overflow Checking} <== Does this hide Turbopower bugs?
|
|
|
|
unit ovcvlb;
|
|
{-Virtual list box component}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF}
|
|
Classes, Controls, Forms, Graphics, StdCtrls, Menus,
|
|
SysUtils, OvcBase, OvcData, OvcCmd, OvcConst, OvcMisc, OvcExcpt, OvcColor;
|
|
|
|
const
|
|
vlbMaxTabStops = 128; {maximum number of tab stops}
|
|
|
|
const
|
|
{default property values}
|
|
vlDefAutoRowHeight = True;
|
|
vlDefAlign = alNone;
|
|
vlDefBorderStyle = bsSingle;
|
|
vlDefColor = clWindow;
|
|
vlDefColumns = 255;
|
|
vlDefCtl3D = True;
|
|
vlDefHeaderBack = clBtnFace;
|
|
vlDefHeaderText = clBtnText;
|
|
vlDefHeight = 150;
|
|
vlDefIntegralHeight = True;
|
|
vlDefItemIndex = -1;
|
|
vlDefMultiSelect = False;
|
|
{$IFDEF MSWINDOWS}
|
|
vlDefNumItems = MaxLongInt; //2,147,483,647
|
|
{$ELSE}
|
|
vlDefNumItems = 126322582; //Apparent max. scrollbar positions with Carbon.
|
|
{$ENDIF} // GTK apparently allows 2,115,747,484.
|
|
vlDefOwnerDraw = False;
|
|
vlDefParentColor = False;
|
|
vlDefParentCtl3D = True;
|
|
vlDefParentFont = True;
|
|
vlDefProtectBack = clRed;
|
|
vlDefProtectText = clWhite;
|
|
vlDefRowHeight = 17;
|
|
vlDefScrollBars = ssVertical;
|
|
vlDefSelectBack = clHighlight;
|
|
vlDefSelectText = clHighlightText;
|
|
vlDefShowHeader = False;
|
|
vlDefTopIndex = 0;
|
|
vlDefTabStop = True;
|
|
vlDefUseTabStops = False;
|
|
vlDefWidth = 100;
|
|
|
|
type
|
|
TCharToItemEvent =
|
|
procedure(Sender : TObject; Ch : Char; var Index : LongInt)
|
|
of object;
|
|
{-event to notify caller of a key press and return new item index}
|
|
TDrawItemEvent =
|
|
procedure(Sender : TObject; Index : LongInt; Rect : TRect; const S : string)
|
|
of object;
|
|
{-event to allow user to draw the cell items}
|
|
TGetItemEvent =
|
|
procedure(Sender : TObject; Index : LongInt; var ItemString : string)
|
|
of object;
|
|
{-event to get string to display}
|
|
TGetItemColorEvent =
|
|
procedure(Sender : TObject; Index : LongInt; var FG, BG : TColor)
|
|
of object;
|
|
{-event to get color of the item cell}
|
|
TGetItemStatusEvent =
|
|
procedure(Sender : TObject; Index : LongInt; var Protect : Boolean)
|
|
of object;
|
|
{-event to get the protected status item cell}
|
|
THeaderClickEvent =
|
|
procedure(Sender : TObject; Point : TPoint)
|
|
of object;
|
|
{-event to notify of a mouse click in the header area}
|
|
TIsSelectedEvent =
|
|
procedure(Sender : TObject; Index : LongInt; var Selected : Boolean)
|
|
of object;
|
|
{-event to get the current selection status from the user}
|
|
TSelectEvent =
|
|
procedure(Sender : TObject; Index : LongInt; Selected : Boolean)
|
|
of object;
|
|
{-event to notify of a selection change}
|
|
TTopIndexChanged =
|
|
procedure(Sender : TObject; NewTopIndex : LongInt)
|
|
of object;
|
|
{-event to notify when the top index changes}
|
|
|
|
type
|
|
TTabStopArray = array[0..vlbMaxTabStops] of Integer;
|
|
TBuffer = array[0..255] of AnsiChar;
|
|
|
|
type
|
|
TOvcCustomVirtualListBox = class(TOvcCustomControlEx)
|
|
{.Z+}
|
|
protected {private}
|
|
{property variables}
|
|
FItemIndex : LongInt; {selected item}
|
|
FAutoRowHeight : Boolean; {true to handle row height calc}
|
|
FBorderStyle : TBorderStyle;{border style to use}
|
|
FColumns : Integer; {number of char columns}
|
|
FFillColor : TColor;
|
|
FHeader : string; {the column header}
|
|
FHeaderColor : TOvcColors; {header line colors}
|
|
FIntegralHeight : Boolean; {adjust height based on font}
|
|
FMultiSelect : Boolean; {allow multiple selections}
|
|
FNumItems : LongInt; {total number of items}
|
|
FOwnerDraw : Boolean; {true if user will draw rows}
|
|
FProtectColor : TOvcColors; {protected item colors}
|
|
FRowHeight : Integer; {height of one row}
|
|
FScrollBars : TScrollStyle;{scroll bar style to use}
|
|
FSelectColor : TOvcColors; {selected item color}
|
|
FShowHeader : Boolean; {true to use the header}
|
|
FSmoothScroll : Boolean; {use smooth scrolling (duh) }
|
|
FTopIndex : LongInt; {item at top of window}
|
|
FUseTabStops : Boolean; {true to use tab stops}
|
|
FWheelDelta : Integer;
|
|
{$IFDEF LCL}
|
|
FCtl3D : Boolean;
|
|
{$ENDIF}
|
|
|
|
{event variables}
|
|
FOnCharToItem : TCharToItemEvent;
|
|
FOnClickHeader : THeaderClickEvent;
|
|
FOnDrawItem : TDrawItemEvent;
|
|
FOnGetItem : TGetItemEvent;
|
|
FOnGetItemColor : TGetItemColorEvent;
|
|
FOnGetItemStatus : TGetItemStatusEvent;
|
|
FOnIsSelected : TIsSelectedEvent;
|
|
FOnSelect : TSelectEvent;
|
|
FOnTopIndexChanged : TTopIndexChanged;
|
|
FOnUserCommand : TUserCommandEvent;
|
|
|
|
{internal/working variables}
|
|
lAnchor : LongInt; {anchor point for extended selections}
|
|
lDivisor : LongInt; {divisor for scroll bars}
|
|
lDlgUnits : Integer; {used for tab spacing}
|
|
lFocusedIndex : LongInt; {index of the focused item}
|
|
lHaveHS : Boolean; {if True, we have a horizontal scroll bar}
|
|
lHaveVS : Boolean; {if True, we have a vertical scroll bar}
|
|
lHDelta : LongInt; {horizontal scroll delta}
|
|
lHighIndex : LongInt; {highest allowable index}
|
|
lNumTabStops : 0..vlbMaxTabStops; {number of tab stops in tabstop array}
|
|
lRows : Integer; {number of rows in window}
|
|
lString : TBuffer; {temp item string buffer}
|
|
lTabs : TTabStopArray;
|
|
lUpdating : Integer; {user updating flag}
|
|
lVSHigh : Integer; {vertical scroll limit}
|
|
lVMargin : Integer; {extra vertical line margin}
|
|
MousePassThru : Boolean;
|
|
|
|
{property methods}
|
|
procedure SetAutoRowHeight(Value : Boolean);
|
|
{-set use of auto row height calculations}
|
|
procedure SetBorderStyle(const Value : TBorderStyle);
|
|
{-set the style used for the border}
|
|
procedure SetColumns(const Value: Integer);
|
|
procedure SetHeader(const Value : string);
|
|
{-set the header at top of list box}
|
|
procedure SetIntegralHeight(Value : Boolean);
|
|
{-set use of integral font height adjustment}
|
|
procedure SetMultiSelect(Value : Boolean); virtual;
|
|
{-set ability to select multiple items}
|
|
procedure InternalSetNumItems(Value : LongInt; Paint, UpdateIndices : Boolean);
|
|
{-set the number of items in the list box}
|
|
procedure SetNumItems(Value : LongInt);
|
|
{-set the number of items in the list box}
|
|
procedure SetRowHeight(Value : Integer);
|
|
{-set height of cell row}
|
|
procedure SetScrollBars(const Value : TScrollStyle); virtual;
|
|
{-set use of vertical and horizontal scroll bars}
|
|
procedure SetShowHeader(Value : Boolean);
|
|
{-set the header at top of list box}
|
|
|
|
{internal methods}
|
|
procedure vlbAdjustIntegralHeight;
|
|
{-adjust height of the list box}
|
|
procedure vlbCalcFontFields; virtual;
|
|
{-calculate sizes based on font selection}
|
|
procedure vlbClearAllItems;
|
|
{-clear the highlight from all items}
|
|
procedure vlbClearSelRange(First, Last : LongInt);
|
|
{-clear the selection for the given range of indexes}
|
|
procedure vlbColorChanged(AColor: TObject);
|
|
{-a color has changed, refresh display}
|
|
procedure vlbDragSelection(First, Last : LongInt);
|
|
{-drag the selection}
|
|
procedure vlbDrawFocusRect(Index : LongInt);
|
|
{-draw the focus rectangle}
|
|
procedure vlbDrawHeader;
|
|
{-draw the header and text area}
|
|
procedure vlbExtendSelection(Index : LongInt);
|
|
{-process Shift-LMouseBtn}
|
|
procedure vlbHScrollPrim(Delta : Integer);
|
|
{-scroll horizontally}
|
|
procedure vlbInitScrollInfo;
|
|
{-setup scroll bar range and initial position}
|
|
procedure vlbMakeItemVisible(Index : LongInt);
|
|
{-make sure the item is visible}
|
|
procedure vlbNewActiveItem(Index : LongInt);
|
|
{-set the currently selected item}
|
|
function vlbScaleDown(N : LongInt) : Integer;
|
|
{-scale down index for scroll bar use}
|
|
function vlbScaleUp(N : LongInt) : LongInt;
|
|
{-scale up scroll index to our index}
|
|
procedure vlbSelectRangePrim(First, Last : LongInt; Select : Boolean);
|
|
{-change the selection for the given range of indexes}
|
|
procedure vlbSetAllItemsPrim(Select : Boolean);
|
|
{-primitive routine thats acts on all items}
|
|
procedure vlbSetFocusedIndex(Index : LongInt);
|
|
{-set focus to this item. invalidate previous}
|
|
procedure vlbSetHScrollPos;
|
|
{-set the horizontal scroll position}
|
|
procedure vlbSetHScrollRange;
|
|
{-set the horizontal scroll range}
|
|
procedure vlbSetSelRange(First, Last : LongInt);
|
|
{-set the selection on for the given range of indexes}
|
|
procedure vlbSetVScrollPos;
|
|
{-set the vertical scroll position}
|
|
procedure vlbSetVScrollRange;
|
|
{-set the vertical scroll range}
|
|
procedure vlbToggleSelection(Index : LongInt);
|
|
{-process Ctrl-LMouseBtn}
|
|
procedure vlbValidateItem(Index : LongInt);
|
|
{-validate the area for this item}
|
|
procedure vlbVScrollPrim(Delta : Integer);
|
|
{-scroll vertically}
|
|
|
|
{VCL control messages}
|
|
{$IFNDEF LCL}
|
|
procedure CMCtl3DChanged(var Message: TMessage);
|
|
message CM_CTL3DCHANGED;
|
|
{$ENDIF}
|
|
procedure CMFontChanged(var Message: TMessage);
|
|
message CM_FONTCHANGED;
|
|
|
|
{windows message methods}
|
|
procedure WMChar(var Msg : TWMChar);
|
|
message WM_CHAR;
|
|
procedure WMEraseBkgnd(var Msg : TWMEraseBkgnd);
|
|
message WM_ERASEBKGND;
|
|
procedure WMGetDlgCode(var Msg : TWMGetDlgCode);
|
|
message WM_GETDLGCODE;
|
|
procedure WMHScroll(var Msg : TWMScroll);
|
|
message WM_HSCROLL;
|
|
procedure WMKeyDown(var Msg : TWMKeyDown);
|
|
message WM_KEYDOWN;
|
|
procedure WMKillFocus(var Msg : TWMKillFocus);
|
|
message WM_KILLFOCUS;
|
|
procedure WMLButtonDown(var Msg : TWMLButtonDown);
|
|
message WM_LBUTTONDOWN;
|
|
procedure WMLButtonDblClk(var Msg : TWMLButtonDblClk);
|
|
message WM_LBUTTONDBLCLK;
|
|
procedure WMMouseActivate(var Msg : TWMMouseActivate);
|
|
message WM_MOUSEACTIVATE;
|
|
procedure WMSetFocus(var Msg : TWMSetFocus);
|
|
message WM_SETFOCUS;
|
|
procedure WMSize(var Msg : TWMSize);
|
|
message WM_SIZE;
|
|
procedure WMVScroll(var Msg : TWMScroll);
|
|
message WM_VSCROLL;
|
|
|
|
{list box messages}
|
|
procedure LBGetCaretIndex(var Msg : TMessage);
|
|
message LB_GETCARETINDEX;
|
|
procedure LBGetCount(var Msg : TMessage);
|
|
message LB_GETCOUNT;
|
|
procedure LBGetCurSel(var Msg : TMessage);
|
|
message LB_GETCURSEL;
|
|
procedure LBGetItemHeight(var Msg : TMessage);
|
|
message LB_GETITEMHEIGHT;
|
|
procedure LBGetItemRect(var Msg : TMessage);
|
|
message LB_GETITEMRECT;
|
|
procedure LBGetSel(var Msg : TMessage);
|
|
message LB_GETSEL;
|
|
procedure LBGetTopIndex(var Msg : TMessage);
|
|
message LB_GETTOPINDEX;
|
|
procedure LBResetContent(var Msg : TMessage);
|
|
message LB_RESETCONTENT;
|
|
procedure LBSelItemRange(var Msg : TMessage);
|
|
message LB_SELITEMRANGE;
|
|
procedure LBSetCurSel(var Msg : TMessage);
|
|
message LB_SETCURSEL;
|
|
procedure LBSetSel(var Msg : TMessage);
|
|
message LB_SETSEL;
|
|
procedure LBSetTabStops(var Msg : TMessage);
|
|
message LB_SETTABSTOPS;
|
|
procedure LBSetTopIndex(var Msg : TMessage);
|
|
message LB_SETTOPINDEX;
|
|
|
|
protected
|
|
procedure ChangeScale(M, D : Integer);
|
|
override;
|
|
procedure CreateParams(var Params: TCreateParams);
|
|
override;
|
|
procedure CreateWnd;
|
|
override;
|
|
procedure DragCanceled;
|
|
override;
|
|
procedure Paint;
|
|
override;
|
|
procedure WndProc(var Message: TMessage);
|
|
override;
|
|
|
|
{event wrappers}
|
|
function DoOnCharToItem(Ch : AnsiChar) : LongInt;
|
|
dynamic;
|
|
{-call the OnCharToItem event, if assigned}
|
|
procedure DoOnClickHeader(Point : TPoint);
|
|
dynamic;
|
|
{-call the OnClickHeader event, if assigned}
|
|
procedure DoOnDrawItem(Index : LongInt; Rect : TRect; const S : string);
|
|
virtual;
|
|
{-call the OnDrawItem event, if assigned}
|
|
function DoOnGetItem(Index : LongInt) : PAnsiChar;
|
|
virtual;
|
|
{-call the OnGetItem event, if assigned}
|
|
procedure DoOnGetItemColor(Index : LongInt; var FG, BG : TColor);
|
|
virtual;
|
|
{-call the OnGetItemColor event, if assigned}
|
|
function DoOnGetItemStatus(Index : LongInt) : Boolean;
|
|
virtual;
|
|
{-call the OnGetItemStatus event, if assigned}
|
|
function DoOnIsSelected(Index : LongInt) : Boolean;
|
|
virtual;
|
|
{-call the OnIsSelected event, if assigned}
|
|
procedure DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt);
|
|
override;
|
|
procedure DoOnSelect(Index : LongInt; Selected : Boolean);
|
|
dynamic;
|
|
{-call the OnSelect event, if assigned}
|
|
procedure DoOnTopIndexChanged(NewTopIndex : LongInt);
|
|
dynamic;
|
|
{-call the OnTopIndexChanged event, if assigned}
|
|
procedure DoOnUserCommand(Command : Word);
|
|
dynamic;
|
|
{-perform notification of a user command}
|
|
|
|
{virtual property methods}
|
|
procedure SetItemIndex(Index : LongInt);
|
|
virtual;
|
|
{-change the currently selected item}
|
|
procedure SetTopIndex(Index : LongInt);
|
|
virtual;
|
|
{-set the index of the first visible entry in the list}
|
|
procedure ForceTopIndex(Index : LongInt; ThumbTracking : Boolean);
|
|
virtual;
|
|
{-re-set the index of the first visible entry in the list - even if it doesn't change}
|
|
|
|
procedure SimulatedClick;
|
|
virtual;
|
|
{-generates a click event when called. Called from SetItemIndex. Introduced so that
|
|
descendants can turn off the behavior.}
|
|
function IsValidIndex(Index : LongInt) : Boolean;
|
|
|
|
{.Z-}
|
|
|
|
{protected properties}
|
|
property AutoRowHeight : Boolean
|
|
read FAutoRowHeight write SetAutoRowHeight default vlDefAutoRowHeight;
|
|
property BorderStyle : TBorderStyle
|
|
read FBorderStyle write SetBorderStyle default vlDefBorderStyle;
|
|
property Columns : Integer
|
|
read FColumns write SetColumns default vlDefColumns;
|
|
property Header : string
|
|
read FHeader write SetHeader;
|
|
property HeaderColor : TOvcColors
|
|
read FHeaderColor write FHeaderColor;
|
|
property IntegralHeight : Boolean
|
|
read FIntegralHeight write SetIntegralHeight default vlDefIntegralHeight;
|
|
property MultiSelect : Boolean
|
|
read FMultiSelect write SetMultiSelect default vlDefMultiSelect;
|
|
property NumItems : LongInt
|
|
read FNumItems write SetNumItems default vlDefNumItems;
|
|
property OwnerDraw : Boolean
|
|
read FOwnerDraw write FOwnerDraw default vlDefOwnerDraw;
|
|
property ProtectColor : TOvcColors
|
|
read FProtectColor write FProtectColor;
|
|
property RowHeight : Integer
|
|
read FRowHeight write SetRowHeight default vlDefRowHeight;
|
|
property ScrollBars : TScrollStyle
|
|
read FScrollBars write SetScrollBars default vlDefScrollBars;
|
|
property SelectColor : TOvcColors
|
|
read FSelectColor write FSelectColor;
|
|
property ShowHeader : Boolean
|
|
read FShowHeader write SetShowHeader default vlDefShowHeader;
|
|
property UseTabStops : Boolean
|
|
read FUseTabStops write FUseTabStops default vlDefUseTabStops;
|
|
property WheelDelta: Integer
|
|
read FWheelDelta write FWheelDelta default 3;
|
|
{$IFDEF LCL}
|
|
property Ctl3D : Boolean read FCtl3D write FCtl3D default vlDefCtl3D;
|
|
{$ENDIF}
|
|
{protected events}
|
|
property OnCharToItem : TCharToItemEvent
|
|
read FOnCharToItem write FOnCharToItem;
|
|
property OnClickHeader : THeaderClickEvent
|
|
read FOnClickHeader write FOnClickHeader;
|
|
property OnDrawItem : TDrawItemEvent
|
|
read FOnDrawItem write FOnDrawItem;
|
|
property OnGetItem : TGetItemEvent
|
|
read FOnGetItem write FOnGetItem;
|
|
property OnGetItemColor : TGetItemColorEvent
|
|
read FOnGetItemColor write FOnGetItemColor;
|
|
property OnGetItemStatus : TGetItemStatusEvent
|
|
read FOnGetItemStatus write FOnGetItemStatus;
|
|
property OnIsSelected : TIsSelectedEvent
|
|
read FOnIsSelected write FOnIsSelected;
|
|
property OnSelect : TSelectEvent
|
|
read FOnSelect write FOnSelect;
|
|
property OnTopIndexChanged : TTopIndexChanged
|
|
read FOnTopIndexChanged write FOnTopIndexChanged;
|
|
property OnUserCommand : TUserCommandEvent
|
|
read FOnUserCommand write FOnUserCommand;
|
|
|
|
public
|
|
|
|
{.Z+}
|
|
constructor Create(AOwner : TComponent);
|
|
override;
|
|
destructor Destroy;
|
|
override;
|
|
{.Z-}
|
|
|
|
procedure BeginUpdate; virtual;
|
|
{-user is updating the list items--don't paint}
|
|
procedure CenterCurrentLine;
|
|
{- center the currently selected line (if any) on screen}
|
|
procedure CenterLine(Index : Integer);
|
|
{- center the specified line (if any) vertically on screen}
|
|
procedure DeselectAll;
|
|
{-deselect all items}
|
|
procedure DrawItem(Index : LongInt);
|
|
{-invalidate and update the area for this item}
|
|
procedure EndUpdate; virtual;
|
|
{-user is done updating the list items--force repaint}
|
|
procedure InsertItemsAt(Items : LongInt; Index : LongInt);
|
|
{-increase NumItems with Items amount while scrolling window down from Index}
|
|
procedure DeleteItemsAt(Items : LongInt; Index : LongInt);
|
|
{-decrease NumItems with Items amount while scrolling window up from Index}
|
|
procedure InvalidateItem(Index : LongInt);
|
|
{-invalidate the area for this item}
|
|
function ItemAtPos(Pos : TPoint; Existing : Boolean) : LongInt;
|
|
{-return the index of the cell that contains the point Pos}
|
|
procedure Scroll(HDelta, VDelta : Integer);
|
|
{-scroll the list by the give delta amount}
|
|
procedure SelectAll;
|
|
{-select all items}
|
|
procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
|
|
override;
|
|
procedure SetTabStops(const Tabs : array of Integer);
|
|
{-set tab stop positions}
|
|
|
|
{public properties}
|
|
property Canvas;
|
|
|
|
property ItemIndex : LongInt
|
|
read FItemIndex write SetItemIndex;
|
|
property FillColor : TColor read FFillColor write FFillColor;
|
|
property SmoothScroll : Boolean
|
|
read FSmoothScroll write FSmoothScroll default True;
|
|
property TopIndex : LongInt
|
|
read FTopIndex write SetTopIndex;
|
|
end;
|
|
|
|
TOvcVirtualListBox = class(TOvcCustomVirtualListBox)
|
|
published
|
|
property AutoRowHeight;
|
|
property BorderStyle;
|
|
property Columns;
|
|
property Header;
|
|
property HeaderColor;
|
|
property IntegralHeight;
|
|
property MultiSelect;
|
|
property NumItems;
|
|
property OwnerDraw;
|
|
property ProtectColor;
|
|
property RowHeight;
|
|
property ScrollBars;
|
|
property SelectColor;
|
|
property ShowHeader;
|
|
property SmoothScroll;
|
|
property UseTabStops;
|
|
property WheelDelta;
|
|
property OnCharToItem;
|
|
property OnClickHeader;
|
|
property OnDrawItem;
|
|
property OnGetItem;
|
|
property OnGetItemColor;
|
|
property OnGetItemStatus;
|
|
property OnIsSelected;
|
|
property OnSelect;
|
|
property OnTopIndexChanged;
|
|
property OnUserCommand;
|
|
|
|
{inherited properties}
|
|
{$IFDEF VERSION4}
|
|
property Anchors;
|
|
property Constraints;
|
|
property DragKind;
|
|
{$ENDIF}
|
|
property Align;
|
|
property Color;
|
|
property Controller;
|
|
property Ctl3D;
|
|
property DragCursor;
|
|
property DragMode;
|
|
property Enabled;
|
|
property Font;
|
|
property ParentColor default vlDefParentColor;
|
|
{$IFNDEF LCL}
|
|
property ParentCtl3D default vlDefParentCtl3D;
|
|
{$ENDIF}
|
|
property ParentFont default vlDefParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop default vlDefTabStop;
|
|
property Visible;
|
|
|
|
{inherited events}
|
|
property AfterEnter;
|
|
property AfterExit;
|
|
property OnClick;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEndDrag;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnMouseDown;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnStartDrag;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
{const
|
|
vlbWheelDelta = 3;} {changed to property}
|
|
|
|
{*** TOvcVirtualListBox ***}
|
|
|
|
procedure TOvcCustomVirtualListBox.BeginUpdate;
|
|
{-user is updating the list items--don't paint}
|
|
begin
|
|
inc(lUpdating);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.CenterCurrentLine;
|
|
{- center the currently selected line (if any) on screen}
|
|
begin
|
|
if ItemIndex <> -1 then
|
|
TopIndex := ItemIndex - (lRows div 2);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.CenterLine(Index : Integer);
|
|
begin
|
|
if Index <> -1 then
|
|
TopIndex := Index - (lRows div 2);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.ChangeScale(M, D : Integer);
|
|
begin
|
|
inherited ChangeScale(M, D);
|
|
|
|
if M <> D then begin
|
|
{scale row height}
|
|
FRowHeight := MulDiv(FRowHeight, M, D);
|
|
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
vlbCalcFontFields;
|
|
vlbInitScrollInfo;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
{$IFNDEF LCL}
|
|
procedure TOvcCustomVirtualListBox.CMCtl3DChanged(var Message: TMessage);
|
|
begin
|
|
if (csLoading in ComponentState) or not HandleAllocated then
|
|
Exit;
|
|
|
|
if NewStyleControls and (FBorderStyle = bsSingle) then
|
|
{$IFNDEF LCL}
|
|
RecreateWnd;
|
|
{$ELSE}
|
|
MyMisc.RecreateWnd(Self);
|
|
{$ENDIF}
|
|
|
|
inherited;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TOvcCustomVirtualListBox.CMFontChanged(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
|
|
if (csLoading in ComponentState) then
|
|
Exit;
|
|
|
|
if not HandleAllocated then
|
|
Exit;
|
|
|
|
{reset internal size variables}
|
|
if FIntegralHeight then begin
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
end;
|
|
|
|
vlbCalcFontFields;
|
|
vlbInitScrollInfo;
|
|
end;
|
|
|
|
constructor TOvcCustomVirtualListBox.Create(AOwner : TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FillColor := Color;
|
|
FSmoothScroll := True;
|
|
|
|
if NewStyleControls then
|
|
ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse, csOpaque]
|
|
else
|
|
ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse, csOpaque, csFramed];
|
|
|
|
{set default values for inherited persistent properties}
|
|
Align := vlDefAlign;
|
|
Color := vlDefColor;
|
|
Ctl3D := vlDefCtl3D;
|
|
Height := vlDefHeight;
|
|
ParentColor := vlDefParentColor;
|
|
{$IFNDEF LCL}
|
|
ParentCtl3D := vlDefParentCtl3D;
|
|
{$ENDIF}
|
|
ParentFont := vlDefParentFont;
|
|
TabStop := vlDefTabStop;
|
|
Width := vlDefWidth;
|
|
|
|
{set default values for new persistent properties}
|
|
FAutoRowHeight := vlDefAutoRowHeight;
|
|
FBorderStyle := vlDefBorderStyle;
|
|
FColumns := vlDefColumns;
|
|
FHeader := '';
|
|
FIntegralHeight := vlDefIntegralHeight;
|
|
FItemIndex := vlDefItemIndex;
|
|
FMultiSelect := vlDefMultiSelect;
|
|
FNumItems := vlDefNumItems;
|
|
FOwnerDraw := vlDefOwnerDraw;
|
|
FRowHeight := vlDefRowHeight;
|
|
FScrollBars := vlDefScrollBars;
|
|
FShowHeader := vlDefShowHeader;
|
|
FTopIndex := vlDefTopIndex;
|
|
FUseTabStops := vlDefUseTabStops;
|
|
|
|
{set defaults for internal variables}
|
|
lHDelta := 0;
|
|
lHaveHS := False;
|
|
lHaveVS := False;
|
|
|
|
lAnchor := 0;
|
|
lFocusedIndex := 0; {-1;}
|
|
|
|
lNumTabStops := 0;
|
|
FillChar(lTabs, SizeOf(lTabs), #0);
|
|
|
|
{create and initialize color objects}
|
|
FHeaderColor := TOvcColors.Create(vlDefHeaderText, vlDefHeaderBack);
|
|
FHeaderColor.OnColorChange := vlbColorChanged;
|
|
FProtectColor := TOvcColors.Create(vlDefProtectText, vlDefProtectBack);
|
|
FProtectColor.OnColorChange := vlbColorChanged;
|
|
FSelectColor := TOvcColors.Create(vlDefSelectText, vlDefSelectBack);
|
|
FSelectColor.OnColorChange := vlbColorChanged;
|
|
FWheelDelta := 3;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited CreateParams(Params);
|
|
|
|
with Params do
|
|
Style := Style or DWord(ScrollBarStyles[FScrollBars])
|
|
or DWord(BorderStyles[FBorderStyle]);
|
|
if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin
|
|
Params.Style := Params.Style and not WS_BORDER;
|
|
Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
|
|
end;
|
|
|
|
{$IFDEF LCL}
|
|
if not (csDesigning in ComponentState) then
|
|
inherited SetBorderStyle(FBorderStyle); //Crashes IDE for some reason
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.CreateWnd;
|
|
begin
|
|
inherited CreateWnd;
|
|
|
|
{do we have scroll bars}
|
|
lHaveVS := FScrollBars in [ssVertical, ssBoth];
|
|
lHaveHS := FScrollBars in [ssHorizontal, ssBoth];
|
|
lHighIndex := Pred(FNumItems);
|
|
|
|
lFocusedIndex := 0; {-1;}
|
|
|
|
{determine the height of one row and number of rows}
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
|
|
{setup scroll bar info}
|
|
vlbInitScrollInfo;
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.DoOnCharToItem(Ch : AnsiChar) : LongInt;
|
|
begin
|
|
Result := FItemIndex;
|
|
if Assigned(FOnCharToItem) then
|
|
FOnCharToItem(Self, Ch, Result);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnClickHeader(Point : TPoint);
|
|
begin
|
|
if Assigned(FOnClickHeader) then
|
|
FOnClickHeader(Self, Point);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnDrawItem(Index : LongInt; Rect : TRect;
|
|
const S : string);
|
|
begin
|
|
if Assigned(FOnDrawItem) then
|
|
FOnDrawItem(Self, Index, Rect, S);
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.DoOnGetItem(Index : LongInt) : PAnsiChar;
|
|
{-returns the string representing Nth item}
|
|
var
|
|
S : string;
|
|
begin
|
|
if Assigned(FOnGetItem) {$IFDEF LCL} and not (csDesigning in ComponentState) {$ENDIF} then begin
|
|
S := '';
|
|
FOnGetItem(Self, Index, S);
|
|
StrPCopy(lString, S);
|
|
Result := @lString[0];
|
|
end else if csDesigning in ComponentState then begin
|
|
StrPCopy(lString, Format(GetOrphStr(SCSampleListItem), [Index]));
|
|
Result := @lString[0];
|
|
end else
|
|
Result := StrPCopy(lString, Format(GetOrphStr(SCGotItemWarning), [Index]));
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnGetItemColor(Index : LongInt; var FG, BG : TColor);
|
|
begin
|
|
if Assigned(FOnGetItemColor) then
|
|
FOnGetItemColor(Self, Index, FG, BG);
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.DoOnGetItemStatus(Index : LongInt) : Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(FOnGetItemStatus) then
|
|
FOnGetItemStatus(Self, Index, Result);
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.DoOnIsSelected(Index : LongInt) : Boolean;
|
|
{-returns the selected status for the "Index" item}
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
Result := Index = 0
|
|
else begin
|
|
Result := (Index = FItemIndex);
|
|
if FMultiSelect then begin
|
|
if Assigned(FOnIsSelected) then
|
|
FOnIsSelected(Self, Index, Result)
|
|
else
|
|
raise EOnIsSelectedNotAssigned.Create;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt);
|
|
var
|
|
I : Integer;
|
|
begin
|
|
inherited DoOnMouseWheel(Shift, Delta, XPos, YPos);
|
|
|
|
if Delta < 0 then begin
|
|
for I := 1 to {vlb}WheelDelta do
|
|
Perform(WM_VSCROLL, MAKELONG(SB_LINEDOWN, 0), 0);
|
|
end else if Delta > 0 then begin
|
|
for I := 1 to {vlb}WheelDelta do
|
|
Perform(WM_VSCROLL, MAKELONG(SB_LINEUP, 0), 0);
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnSelect(Index : LongInt; Selected : Boolean);
|
|
{-notify of selection change}
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
Exit;
|
|
|
|
if FMultiSelect then begin
|
|
if Assigned(FOnSelect) then begin
|
|
{select if not protected-deselect always}
|
|
if (not Selected) or (not DoOnGetItemStatus(Index)) then
|
|
FOnSelect(Self, Index, Selected);
|
|
end else
|
|
raise EOnSelectNotAssigned.Create;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnTopIndexChanged(NewTopIndex : LongInt);
|
|
{-call the OnTopIndexChanged event, if assigned}
|
|
begin
|
|
if Assigned(FOnTopIndexChanged) then
|
|
FOnTopIndexChanged(Self, NewTopIndex);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DoOnUserCommand(Command : Word);
|
|
{-perform notification of a user command}
|
|
begin
|
|
if Assigned(FOnUserCommand) then
|
|
FOnUserCommand(Self, Command);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DeselectAll;
|
|
{-deselect all items}
|
|
begin
|
|
vlbSetAllItemsPrim(False {deselect});
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DrawItem(Index : LongInt);
|
|
{-invalidate and update the area for this item}
|
|
begin
|
|
InvalidateItem(Index);
|
|
Update;
|
|
end;
|
|
|
|
destructor TOvcCustomVirtualListBox.Destroy;
|
|
begin
|
|
{if lUpdating <> 0 then debug code}
|
|
{raise Exception.Create('Mismatched BeginUpdate/EndUpdate');}
|
|
FHeaderColor.Free;
|
|
FProtectColor.Free;
|
|
FSelectColor.Free;
|
|
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.EndUpdate;
|
|
{-user is done updating the list items--force repaint}
|
|
begin
|
|
dec(lUpdating);
|
|
if lUpdating < 0 then
|
|
raise Exception.Create('Mismatched BeginUpdate/EndUpdate');
|
|
if lUpdating = 0 then
|
|
Invalidate;
|
|
end;
|
|
|
|
function ScrollCanvas(Canvas : TCanvas; R : TRect; EastWest : Boolean; Distance : Integer;
|
|
Smooth : Boolean) : TRect;
|
|
var
|
|
UpdRect : TRect;
|
|
NextStep,StepSize : Integer;
|
|
{OldColor : TColor;}
|
|
begin
|
|
if Distance = 0 then begin
|
|
Result := Rect(0,0,0,0);
|
|
exit;
|
|
end;
|
|
if Smooth then
|
|
StepSize := MaxI((Abs(Distance) div 4), MinI(2, Abs(Distance)))
|
|
else
|
|
StepSize := Abs(Distance);
|
|
Result := R;
|
|
if EastWest then
|
|
if abs(Distance) < (Result.Right-Result.Left+1) then
|
|
if Distance < 0 then
|
|
Result.Left := Result.Right + Distance
|
|
else
|
|
Result.Right := Result.Left + Distance
|
|
else
|
|
else
|
|
if abs(Distance) < (Result.Bottom-Result.Top+1) then
|
|
if Distance < 0 then
|
|
Result.Top := Result.Bottom + Distance
|
|
else
|
|
Result.Bottom := Result.Top + Distance;
|
|
repeat
|
|
if Distance > 0 then
|
|
if Distance > StepSize then
|
|
NextStep := StepSize
|
|
else
|
|
NextStep := Distance
|
|
else
|
|
if Distance < -StepSize then
|
|
NextStep := -StepSize
|
|
else
|
|
NextStep := Distance;
|
|
if EastWest then
|
|
ScrollDC(Canvas.Handle,NextStep,0,R,R,0,@UpdRect)
|
|
else
|
|
ScrollDC(Canvas.Handle,0,NextStep,R,R,0,@UpdRect);
|
|
UnionRect(Result, UpdRect, Result);
|
|
dec(Distance,NextStep);
|
|
until Distance = 0;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.InsertItemsAt(Items : LongInt; Index : LongInt);
|
|
{-increase NumItems with Items amount while scrolling window down from Index}
|
|
var
|
|
CR : TRect;
|
|
AbsBottom : Integer;
|
|
OldItemIndex : Integer;
|
|
begin
|
|
OldItemIndex := ItemIndex;
|
|
ItemIndex := -1;
|
|
InternalSetNumItems(NumItems + Items,False,False);
|
|
if (lUpdating = 0) then
|
|
if (Index-FTopIndex) < lRows then begin
|
|
AbsBottom := (ClientRect.Bottom div FRowHeight) * FRowHeight;
|
|
if Index >= FTopIndex then begin
|
|
CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom);
|
|
{Make sure the canvas is updated,
|
|
because we will be validating the scrolled portion.}
|
|
CR := ScrollCanvas(Canvas, CR, False, Items*FRowHeight, FSmoothScroll);
|
|
InvalidateRect(Handle,@CR,False);
|
|
end else begin
|
|
CR := Rect(0, (Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom);
|
|
Update;
|
|
{Make sure the canvas is updated,
|
|
because we will be validating the scrolled portion.}
|
|
CR := ScrollCanvas(Canvas, CR, False, Items*FRowHeight, FSmoothScroll);
|
|
InvalidateRect(Handle, @CR, False);
|
|
Update;
|
|
end;
|
|
end;
|
|
if OldItemIndex >= Index then
|
|
inc(OldItemIndex,Items);
|
|
ItemIndex := OldItemIndex;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DeleteItemsAt(Items : LongInt; Index : LongInt);
|
|
{-decrease NumItems with Items amount while scrolling window up from Index}
|
|
var
|
|
CR : TRect;
|
|
AbsBottom,OldItemIndex : Integer;
|
|
begin
|
|
OldItemIndex := ItemIndex;
|
|
ItemIndex := -1;
|
|
if lUpdating = 0 then
|
|
Update;
|
|
InternalSetNumItems(NumItems - Items,False,False);
|
|
if lUpdating = 0 then begin
|
|
if (Index-FTopIndex) < lRows then begin
|
|
AbsBottom := (ClientRect.Bottom div FRowHeight) * FRowHeight;
|
|
if Index >= FTopIndex then begin
|
|
CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom);
|
|
CR := ScrollCanvas(Canvas, CR, False, -Items*FRowHeight, FSmoothScroll);
|
|
InvalidateRect(Handle,@CR,False);
|
|
Update;
|
|
end else begin
|
|
CR := Rect(0, (Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom);
|
|
CR := ScrollCanvas(Canvas, CR, False, -Items*FRowHeight, FSmoothScroll);
|
|
InvalidateRect(Handle,@CR,False);
|
|
Update;
|
|
end;
|
|
end;
|
|
end;
|
|
if OldItemIndex >= Index+Items then
|
|
dec(OldItemIndex,Items)
|
|
else
|
|
if OldItemIndex >= Index then
|
|
OldItemIndex := -1;
|
|
ItemIndex := OldItemIndex;
|
|
if TopIndex + lRows > FNumItems then
|
|
ForceTopIndex(FNumItems - 1, True)
|
|
else
|
|
ForceTopIndex(TopIndex, False);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.InvalidateItem(Index : LongInt);
|
|
{-invalidate the area for this item}
|
|
var
|
|
CR : TRect;
|
|
begin
|
|
if (Index >= FTopIndex) and (Index-FTopIndex < lRows) then begin {visible?}
|
|
CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, 0);
|
|
CR.Bottom := CR.Top+FRowHeight;
|
|
InvalidateRect(Handle, @CR, True);
|
|
end;
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.ItemAtPos(Pos : TPoint;
|
|
Existing : Boolean) : LongInt;
|
|
{-return the index of the cell that contains the point Pos}
|
|
begin
|
|
if (Pos.Y < Ord(FShowHeader)*FRowHeight) then begin
|
|
if Existing then
|
|
Result := -1
|
|
else
|
|
Result := 0;
|
|
end else if (Pos.Y >= ClientHeight) then begin
|
|
if Existing then
|
|
Result := -1
|
|
else
|
|
Result := lHighIndex;
|
|
end else begin {convert to an index}
|
|
Result := FTopIndex-Ord(FShowHeader)+(Pos.Y div FRowHeight);
|
|
{test for click below last item (IntegralHeight not set)}
|
|
if ClientHeight mod FRowHeight > 0 then
|
|
if Result > FTopIndex+lRows-1 then
|
|
Result := FTopIndex+lRows-1;
|
|
if Result > NumItems then
|
|
if Existing then
|
|
Result := -1
|
|
else
|
|
Result := NumItems;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetCaretIndex(var Msg : TMessage);
|
|
begin
|
|
Msg.Result := lFocusedIndex;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetCount(var Msg : TMessage);
|
|
begin
|
|
Msg.Result := FNumItems;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetCurSel(var Msg : TMessage);
|
|
begin
|
|
Msg.Result := FItemIndex;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetItemHeight(var Msg : TMessage);
|
|
begin
|
|
Msg.Result := FRowHeight;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetItemRect(var Msg : TMessage);
|
|
begin
|
|
PRect(Msg.LParam)^ :=
|
|
Rect(0, (Msg.WParam - FTopIndex) * FRowHeight,
|
|
ClientWidth, (Msg.WParam - FTopIndex) * FRowHeight + FRowHeight);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetSel(var Msg : TMessage);
|
|
begin
|
|
if (Msg.wParam >= 0) and (Msg.wParam <= lHighIndex) then
|
|
Msg.Result := Ord(DoOnIsSelected(Msg.wParam))
|
|
else
|
|
Msg.Result := LB_ERR;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBGetTopIndex(var Msg : TMessage);
|
|
begin
|
|
Msg.Result := FTopIndex;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBResetContent(var Msg : TMessage);
|
|
begin
|
|
NumItems := 0;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBSelItemRange(var Msg : TMessage);
|
|
begin
|
|
if FMultiSelect and (LoWord(Msg.WParam) <= lHighIndex) //64
|
|
and (HiWord(Msg.WParam) <= lHighIndex) then begin //64
|
|
vlbSelectRangePrim(LoWord(Msg.LParam), HiWord(Msg.LParam), Msg.wParam > 0); //64
|
|
Msg.Result := 0;
|
|
end else
|
|
Msg.Result := LB_ERR;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBSetCurSel(var Msg : TMessage);
|
|
begin
|
|
if FMultiSelect and (Msg.wParam >= -1) and (Msg.wParam <= lHighIndex) then begin
|
|
SetItemIndex(Msg.wParam);
|
|
if Msg.wParam = $FFFF then
|
|
Msg.Result := LB_ERR
|
|
else
|
|
Msg.Result := 0;
|
|
end else
|
|
Msg.Result := LB_ERR;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBSetSel(var Msg : TMessage);
|
|
begin
|
|
if FMultiSelect and (Msg.lParam >= -1) and (Msg.lParam <= lHighIndex) then begin
|
|
if Msg.lParam = -1 then
|
|
vlbSetAllItemsPrim(Msg.wParam > 0)
|
|
else begin
|
|
DoOnSelect(Msg.lParam, Msg.wParam > 0);
|
|
InvalidateItem(Msg.lParam);
|
|
end;
|
|
Msg.Result := 0;
|
|
end else
|
|
Msg.Result := LB_ERR;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBSetTabStops(var Msg : TMessage);
|
|
type
|
|
IA = TTabStopArray;
|
|
IP = ^IA;
|
|
var
|
|
I : Integer;
|
|
begin
|
|
lNumTabStops := Msg.wParam;
|
|
if lNumTabStops > vlbMaxTabStops then begin
|
|
lNumTabStops := vlbMaxTabStops;
|
|
Msg.Result := 0; {didn't set all tabs}
|
|
end else
|
|
Msg.Result := 1;
|
|
|
|
for I := 0 to Pred(lNumTabStops) do
|
|
lTabs[I] := IP(Msg.lParam)^[I] * lDlgUnits;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.LBSetTopIndex(var Msg : TMessage);
|
|
begin
|
|
if (Msg.wParam >= 0) and (Msg.wParam <= lHighIndex) then begin
|
|
SetTopIndex(Msg.wParam);
|
|
Msg.Result := 0;
|
|
end else
|
|
Msg.Result := LB_ERR;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.Paint;
|
|
var
|
|
I : Integer;
|
|
ST : PAnsiChar;
|
|
CR : TRect;
|
|
IR : TRect;
|
|
Clip : TRect;
|
|
Last : Integer;
|
|
|
|
{20070204 workaround for recent change to FPC that
|
|
no longer permits nested procedure to have same
|
|
name as other method in class.}
|
|
{$IFNDEF FPC}
|
|
procedure DrawItem(N : LongInt; Row : Integer);
|
|
{$ELSE}
|
|
procedure DrawItem2(N : LongInt; Row : Integer);
|
|
{$ENDIF}
|
|
{-Draw item N at Row}
|
|
var
|
|
S : PAnsiChar;
|
|
FGColor : TColor;
|
|
BGColor : TColor;
|
|
DX : Integer;
|
|
begin
|
|
{get bounding rectangle}
|
|
CR.Top := Pred(Row)*FRowHeight;
|
|
CR.Bottom := CR.Top+FRowHeight;
|
|
|
|
{do we have anything to paint}
|
|
if Bool(IntersectRect(IR, Clip, CR)) then begin
|
|
|
|
{get colors}
|
|
if DoOnGetItemStatus(N) then begin
|
|
BGColor := FProtectColor.BackColor;
|
|
FGColor := FProtectColor.TextColor;
|
|
end else if DoOnIsSelected(N) and (Row <= lRows+Ord(FShowHeader)) then begin
|
|
BGColor := FSelectColor.BackColor;
|
|
FGColor := FSelectColor.TextColor;
|
|
end else begin
|
|
BGColor := Color;
|
|
FGColor := Font.Color;
|
|
DoOnGetItemColor(N, FGColor, BGColor);
|
|
end;
|
|
|
|
{assign colors to our canvas}
|
|
Canvas.Brush.Color := BGColor;
|
|
Canvas.Font.Color := FGColor;
|
|
|
|
{clear the line}
|
|
Canvas.FillRect(CR);
|
|
|
|
{get the string}
|
|
if N <= lHighIndex then begin
|
|
ST := DoOnGetItem(N);
|
|
if lHDelta >= LongInt(StrLen(ST)) then
|
|
S := nil
|
|
else
|
|
S := @ST[lHDelta];
|
|
end else
|
|
S := nil;
|
|
|
|
{draw the string}
|
|
if S <> nil then begin
|
|
if FOwnerDraw then
|
|
DoOnDrawItem(N, CR, StrPas(S))
|
|
else if FUseTabStops then begin
|
|
DX := 0;
|
|
if lHDelta > 0 then begin
|
|
{measure portion of string to the left of the window}
|
|
DX := LOWORD(GetTabbedTextExtent(Canvas.Handle,
|
|
ST, lHDelta, lNumTabStops, lTabs));
|
|
end;
|
|
TabbedTextOut(Canvas.Handle, CR.Left+2, CR.Top,
|
|
S, StrLen(S), lNumTabStops, lTabs, -DX)
|
|
end else
|
|
ExtTextOut(Canvas.Handle, CR.Left+2, CR.Top,
|
|
ETO_CLIPPED + ETO_OPAQUE, @CR, S, StrLen(S), nil);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
{exit if the updating flag is set}
|
|
if lUpdating > 0 then
|
|
Exit;
|
|
|
|
Canvas.Font := Font;
|
|
|
|
{we will erase our own background}
|
|
SetBkMode(Canvas.Handle, TRANSPARENT);
|
|
|
|
{get the client rectangle}
|
|
CR := ClientRect;
|
|
|
|
{get the clipping region}
|
|
{$IFNDEF LCL}
|
|
GetClipBox(Canvas.Handle, Clip);
|
|
{$ELSE}
|
|
GetClipBox(Canvas.Handle, @Clip);
|
|
{$ENDIF}
|
|
|
|
{do we have a header?}
|
|
if FShowHeader then begin
|
|
if Bool(IntersectRect(IR, Clip, Rect(CR.Left, CR.Top, CR.Right, FRowHeight))) then
|
|
vlbDrawHeader;
|
|
end;
|
|
|
|
{calculate last visible item}
|
|
Last := lRows;
|
|
if Last > NumItems then
|
|
Last := NumItems;
|
|
|
|
{display each row}
|
|
for I := 1 to Last do
|
|
{$IFNDEF FPC}
|
|
DrawItem(FTopIndex+Pred(I), I+Ord(FShowHeader));
|
|
{$ELSE}
|
|
DrawItem2(FTopIndex+Pred(I), I+Ord(FShowHeader));
|
|
{$ENDIF}
|
|
|
|
{paint any blank area below last item}
|
|
CR.Top := FRowHeight * (Last+Ord(FShowHeader));
|
|
if CR.Top < ClientHeight then begin
|
|
CR.Bottom := ClientHeight;
|
|
{clear the area}
|
|
Canvas.Brush.Color := Color;
|
|
Canvas.FillRect(CR);
|
|
end;
|
|
|
|
Canvas.Brush.Color := Color;
|
|
Canvas.Font.Color := Font.Color;
|
|
if Canvas.Handle > 0 then {force colors to be selected into canvas};
|
|
{conditionally, draw the focus rect}
|
|
if lFocusedIndex <> -1 then
|
|
vlbDrawFocusRect(lFocusedIndex);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.DragCanceled;
|
|
var
|
|
M: TWMMouse;
|
|
P, MousePos: TPoint;
|
|
begin
|
|
with M do
|
|
begin
|
|
Msg := WM_LBUTTONDOWN;
|
|
GetCursorPos(MousePos);
|
|
P := ScreenToClient(MousePos);
|
|
Pos := PointToSmallPoint(P);
|
|
Keys := 0;
|
|
Result := 0;
|
|
end;
|
|
DefaultHandler(M);
|
|
M.Msg := WM_LBUTTONUP;
|
|
DefaultHandler(M);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WndProc(var Message: TMessage);
|
|
begin
|
|
{for auto drag mode, let listbox handle itself, instead of TControl}
|
|
if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
|
|
(Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging then
|
|
begin
|
|
if DragMode = dmAutomatic then
|
|
begin
|
|
if IsControlMouseMsg(TWMMouse(Message)) then
|
|
Exit;
|
|
ControlState := ControlState + [csLButtonDown];
|
|
Dispatch(Message); {overrides TControl's BeginDrag}
|
|
Exit;
|
|
end;
|
|
end;
|
|
inherited WndProc(Message);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.Scroll(HDelta, VDelta : Integer);
|
|
{-scroll the list by the give delta amount}
|
|
begin
|
|
if HDelta <> 0 then
|
|
vlbHScrollPrim(HDelta);
|
|
|
|
if VDelta <> 0 then
|
|
vlbVScrollPrim(VDelta);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SelectAll;
|
|
{-select all items}
|
|
begin
|
|
vlbSetAllItemsPrim(True {select});
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetAutoRowHeight(Value : Boolean);
|
|
{-set use of auto row height calculations}
|
|
begin
|
|
if Value <> FAutoRowHeight then begin
|
|
FAutoRowHeight := Value;
|
|
if FAutoRowHeight then begin
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
vlbCalcFontFields;
|
|
vlbInitScrollInfo;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetBorderStyle(const Value : TBorderStyle);
|
|
{-set the style used for the border}
|
|
begin
|
|
if Value <> FBorderStyle then begin
|
|
FBorderStyle := Value;
|
|
{$IFNDEF LCL}
|
|
RecreateWnd;
|
|
{$ELSE}
|
|
MyMisc.RecreateWnd(Self);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
|
|
begin
|
|
if not (Align in [alNone, alTop, alBottom]) then
|
|
FIntegralHeight := False;
|
|
|
|
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetHeader(const Value : string);
|
|
{-set the header at top of list box}
|
|
begin
|
|
if Value <> FHeader then begin
|
|
FHeader := Value;
|
|
{toggle show header flag as appropriate}
|
|
if (csDesigning in ComponentState) and not (csLoading in ComponentState) then
|
|
ShowHeader := FHeader <> '';
|
|
Repaint;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetIntegralHeight(Value : Boolean);
|
|
{-set use of integral font height adjustment}
|
|
begin
|
|
if (Value <> FIntegralHeight) and (Align in [alNone, alTop, alBottom]) then begin
|
|
FIntegralHeight := Value;
|
|
if FIntegralHeight then begin
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
vlbCalcFontFields;
|
|
vlbInitScrollInfo;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetItemIndex(Index : LongInt);
|
|
{-change the currently selected item}
|
|
begin
|
|
{verify valid index}
|
|
if Index > lHighIndex then
|
|
if lHighIndex < 0 then
|
|
Index := -1
|
|
else
|
|
Index := lHighIndex;
|
|
|
|
{do we need to do any more}
|
|
if (Index = FItemIndex) then
|
|
Exit;
|
|
|
|
{erase current selection}
|
|
InvalidateItem(FItemIndex);
|
|
|
|
{if Index <> -1 then}
|
|
DoOnSelect(FItemIndex, False);
|
|
|
|
{set the newly selected item index}
|
|
FItemIndex := Index;
|
|
{lFocusedIndex := -1;}
|
|
Update;
|
|
|
|
if csDesigning in ComponentState then
|
|
Exit;
|
|
|
|
{vlbMakeItemVisible(Index);}
|
|
if FItemIndex > -1 then begin
|
|
vlbMakeItemVisible(Index);
|
|
DoOnSelect(FItemIndex, True);
|
|
end;
|
|
if FItemIndex <> -1 then
|
|
vlbSetFocusedIndex(FItemIndex)
|
|
else
|
|
vlbSetFocusedIndex(0);
|
|
DrawItem(FItemIndex);
|
|
|
|
{notify of an index change}
|
|
if not MouseCapture then
|
|
SimulatedClick;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SimulatedClick;
|
|
begin
|
|
Click;
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.IsValidIndex(Index : LongInt) : Boolean;
|
|
begin
|
|
Result := (Index >= 0) and (Index <= lHighIndex);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetMultiSelect(Value : Boolean);
|
|
{-set ability to select multiple items}
|
|
begin
|
|
if (csDesigning in ComponentState) or (csLoading in ComponentState) then
|
|
if Value <> FMultiSelect then
|
|
FMultiSelect := Value;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.InternalSetNumItems(Value : LongInt; Paint, UpdateIndices : Boolean);
|
|
{-set the number of items in the list box}
|
|
var
|
|
OldNumItems : LongInt;
|
|
begin
|
|
if Value <> FNumItems then begin
|
|
if (Value < 0) then
|
|
{$IFDEF MSWINDOWS}
|
|
Value := MaxLongInt;
|
|
{$ELSE}
|
|
Value := vlDefNumItems;
|
|
{$ENDIF}
|
|
|
|
OldNumItems := FNumItems;
|
|
{set new item index}
|
|
FNumItems := Value;
|
|
|
|
{reset high index}
|
|
lHighIndex := Pred(FNumItems);
|
|
{reset horizontal offset}
|
|
lHDelta := 0;
|
|
|
|
{reset selected item}
|
|
if UpdateIndices then
|
|
if not (csLoading in ComponentState) then begin
|
|
if ItemIndex >= FNumItems then
|
|
ItemIndex := -1;
|
|
if TopIndex + lRows > FNumItems then
|
|
ForceTopIndex(FNumItems - 1, True)
|
|
else
|
|
ForceTopIndex(TopIndex, False);
|
|
end;
|
|
if Paint and ((NumItems <= lRows) or (OldNumItems <= lRows)) then
|
|
Repaint;
|
|
|
|
vlbInitScrollInfo;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetNumItems(Value : LongInt);
|
|
{-set the number of items in the list box}
|
|
begin
|
|
InternalSetNumItems(Value, True, True);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetRowHeight(Value : Integer);
|
|
{-set height of cell row}
|
|
begin
|
|
if Value <> FRowHeight then begin
|
|
FRowHeight := Value;
|
|
if not (csLoading in ComponentState) then
|
|
AutoRowHeight := False;
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
vlbCalcFontFields;
|
|
vlbInitScrollInfo;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetScrollBars(const Value : TScrollStyle);
|
|
{-set use of vertical and horizontal scroll bars}
|
|
begin
|
|
if Value <> FScrollBars then begin
|
|
FScrollBars := Value;
|
|
lHaveVS := (FScrollBars = ssVertical) or (FScrollBars = ssBoth);
|
|
lHaveHS := (FScrollBars = ssHorizontal) or (FScrollBars = ssBoth);
|
|
{$IFNDEF LCL}
|
|
RecreateWnd;
|
|
{$ELSE}
|
|
MyMisc.RecreateWnd(Self);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetShowHeader(Value : Boolean);
|
|
{-set show flag for the header}
|
|
begin
|
|
if Value <> FShowHeader then begin
|
|
FShowHeader := Value;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetTabStops(const Tabs : array of Integer);
|
|
{-set tab stop positions}
|
|
var
|
|
I : Integer;
|
|
begin
|
|
HandleNeeded;
|
|
lNumTabStops := High(Tabs)+1;
|
|
if lNumTabStops > vlbMaxTabStops then
|
|
lNumTabStops := vlbMaxTabStops;
|
|
for I := 0 to Pred(lNumTabStops) do
|
|
lTabs[I] := Tabs[I] * lDlgUnits;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.ForceTopIndex(Index : LongInt; ThumbTracking : Boolean);
|
|
{-set the index of the first visible entry in the list}
|
|
var
|
|
DY : LongInt;
|
|
SaveD : LongInt;
|
|
ClipBox,
|
|
TmpArea,
|
|
ClipArea : TRect;
|
|
Inv : TRect;
|
|
begin
|
|
if (Index >= 0) and (Index <= lHighIndex) then begin
|
|
Update;
|
|
SaveD := FTopIndex;
|
|
{if we can't make the requested item the top one, at least show it}
|
|
if Index + lRows -1 <= lHighIndex then
|
|
FTopIndex := Index
|
|
else
|
|
FTopIndex := lHighIndex - lRows + 1;
|
|
|
|
{check for valid index}
|
|
if FTopIndex < 0 then
|
|
FTopIndex := 0;
|
|
if FTopIndex = SaveD then
|
|
Exit;
|
|
vlbSetVScrollPos;
|
|
ClipArea := ClientRect;
|
|
{adjust top of the clipping region to exclude the header, if any}
|
|
if FShowHeader then with ClipArea do
|
|
Top := Top + FRowHeight;
|
|
|
|
{$IFNDEF LCL}
|
|
if GetClipBox(Canvas.Handle, ClipBox) <> SIMPLEREGION then
|
|
{$ELSE} //Something about code below doesn't work so just always InvalidateRect
|
|
// for now as workaround. If bug is in ScrollCanvas, then InsertItemsAt
|
|
// and DeleteItemsAt will probably also need a similar workaround.
|
|
if GetClipBox(Canvas.Handle, @ClipBox) <> Region_Error then
|
|
{$ENDIF}
|
|
InvalidateRect(Handle, @ClipArea, True)
|
|
else begin
|
|
InterSectRect(ClipArea, ClipArea, ClipBox);
|
|
|
|
TmpArea := ClipArea;
|
|
TmpArea.Bottom := ClipArea.Bottom;
|
|
{adjust bottom of the clipping region to an even number of rows}
|
|
with ClipArea do
|
|
Bottom := (Bottom div FRowHeight) * FRowHeight;
|
|
TmpArea.Top := ClipArea.Bottom;
|
|
{if ThumbTracking then
|
|
InvalidateRect(Handle, @ClipArea, True)
|
|
else} begin
|
|
DY := (SaveD - FTopIndex);
|
|
if Abs(DY) > lRows then
|
|
DY := lRows;
|
|
DY := DY * FRowHeight;
|
|
Update;
|
|
{Make sure the canvas is updated,
|
|
because we will be validating the scrolled portion.}
|
|
Inv := ScrollCanvas(Canvas, ClipArea, False, DY, (not ThumbTracking) and FSmoothScroll);
|
|
InvalidateRect(Handle, @Inv, False);
|
|
InvalidateRect(Handle, @TmpArea, False);
|
|
if SaveD <> FTopIndex then begin
|
|
DoOnTopIndexChanged(FTopIndex);
|
|
SaveD := FTopIndex;
|
|
end;
|
|
Update;
|
|
end;
|
|
end;
|
|
vlbSetFocusedIndex(FItemIndex);
|
|
|
|
{notify that top index has changed}
|
|
if SaveD <> FTopIndex then
|
|
DoOnTopIndexChanged(FTopIndex);
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.SetTopIndex(Index : LongInt);
|
|
{-set the index of the first visible entry in the list}
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
Exit;
|
|
|
|
if Index <> FTopIndex then
|
|
ForceTopIndex(Index, False);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbAdjustIntegralHeight;
|
|
begin
|
|
if (csDesigning in ComponentState) and
|
|
not (csLoading in ComponentState) then
|
|
if FIntegralHeight then
|
|
if ClientHeight mod FRowHeight <> 0 then
|
|
ClientHeight := (ClientHeight div FRowHeight) * FRowHeight;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbCalcFontFields;
|
|
var
|
|
Alpha : string;
|
|
begin
|
|
if not HandleAllocated then
|
|
Exit;
|
|
|
|
Alpha := GetOrphStr(SCAlphaString);
|
|
|
|
{set the canvas font}
|
|
Canvas.Font := Self.Font;
|
|
|
|
{determine the height of one row}
|
|
if FAutoRowHeight and not (csLoading in ComponentState) then
|
|
FRowHeight := Canvas.TextHeight(GetOrphStr(SCTallLowChars)) + lVMargin;
|
|
lRows := (ClientHeight div FRowHeight)-Ord(FShowHeader);
|
|
if lRows < 1 then
|
|
lRows := 1;
|
|
|
|
{calculate the base dialog unit for tab spacing}
|
|
lDlgUnits := (Canvas.TextWidth(Alpha) div Length(Alpha)) div 4
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbClearAllItems;
|
|
{-clear the highlight from all items}
|
|
begin
|
|
vlbSetAllItemsPrim(False);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbClearSelRange(First, Last : LongInt);
|
|
{-clear the selection for the given range of indexes}
|
|
begin
|
|
vlbSelectRangePrim(First, Last, False);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbColorChanged(AColor: TObject);
|
|
{-a color has changed, refresh display}
|
|
begin
|
|
Refresh;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbDrawFocusRect(Index : LongInt);
|
|
{-draw the focus rectangle}
|
|
var
|
|
CR : TRect;
|
|
begin
|
|
if Index < 0 then exit;
|
|
if Focused then begin
|
|
if (Index >= FTopIndex) and (Index-FTopIndex <= Pred(lRows)) then begin
|
|
CR := ClientRect;
|
|
CR.Top := (Index-FTopIndex+Ord(FShowHeader))*FRowHeight;
|
|
CR.Bottom := CR.Top + FRowHeight;
|
|
Canvas.DrawFocusRect(CR);
|
|
end;
|
|
end;
|
|
lFocusedIndex := Index;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbDragSelection(First, Last : LongInt);
|
|
{-drag the selection}
|
|
var
|
|
I : LongInt;
|
|
OutSide : Boolean;
|
|
begin
|
|
|
|
{set new active item}
|
|
vlbNewActiveItem(Last);
|
|
|
|
{remove selection from visible selected items not in range}
|
|
for I := FTopIndex to FTopIndex+Pred(lRows) do begin
|
|
if First <= Last then
|
|
OutSide := (I < First) or (I > Last)
|
|
else
|
|
OutSide := (I < Last) or (I > First);
|
|
|
|
if DoOnIsSelected(I) and OutSide then
|
|
InvalidateItem(I);
|
|
|
|
end;
|
|
|
|
{deselect all items}
|
|
DoOnSelect(-1, False);
|
|
|
|
{select new range}
|
|
vlbSetSelRange(First, Last);
|
|
vlbSetFocusedIndex(Last);
|
|
Update;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbDrawHeader;
|
|
{-draw the header and text}
|
|
var
|
|
R : TRect;
|
|
Buf : array[0..255] of AnsiChar;
|
|
S : PAnsiChar;
|
|
DX : Integer;
|
|
begin
|
|
{get the printable area of the header text}
|
|
StrPCopy(Buf, FHeader);
|
|
if lHDelta >= LongInt(StrLen(Buf)) then
|
|
S := ' ' {space to erase last character from header}
|
|
else
|
|
S := @Buf[lHDelta];
|
|
|
|
Canvas.Font := Font;
|
|
with Canvas do begin
|
|
{draw header text}
|
|
Brush.Color := FHeaderColor.BackColor;
|
|
Font.Color := FHeaderColor.TextColor;
|
|
|
|
R := Bounds(0, 0, Width, FRowHeight-1);
|
|
|
|
{clear the line}
|
|
Canvas.FillRect(R);
|
|
|
|
if S <> nil then
|
|
if FUseTabStops then begin
|
|
DX := 0;
|
|
if lHDelta > 0 then begin
|
|
{measure portion of string to the left of the window}
|
|
DX := LOWORD(GetTabbedTextExtent(Canvas.Handle, Buf, lHDelta,
|
|
lNumTabStops, lTabs));
|
|
end;
|
|
TabbedTextOut(Canvas.Handle, 2, 0,
|
|
S, StrLen(S), lNumTabStops, lTabs, -DX)
|
|
end else
|
|
ExtTextOut(Canvas.Handle, 2, 0, ETO_OPAQUE + ETO_CLIPPED,
|
|
@R, S, StrLen(S), nil);
|
|
|
|
{draw border line}
|
|
Pen.Color := clBlack;
|
|
PolyLine([Point(R.Left, R.Bottom), Point(R.Right, R.Bottom)]);
|
|
|
|
{draw ctl3d highlight}
|
|
if Ctl3D then begin
|
|
Pen.Color := clBtnHighlight;
|
|
PolyLine([Point(R.Left, R.Bottom-1),
|
|
Point(R.Left, R.Top),
|
|
Point(R.Right, R.Top)]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbExtendSelection(Index : LongInt);
|
|
{-process Shift-LMouseBtn}
|
|
begin
|
|
{verify valid index}
|
|
if Index < 0 then
|
|
Index := 0
|
|
else if Index > lHighIndex then
|
|
Index := lHighIndex;
|
|
|
|
{clear current selections}
|
|
vlbClearAllItems;
|
|
|
|
{set selection for all items from the active one to the currently selected item}
|
|
vlbSetSelRange(lAnchor, Index);
|
|
|
|
{set new active item}
|
|
FItemIndex := Index;
|
|
vlbSetFocusedIndex(FItemIndex);
|
|
Update;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbHScrollPrim(Delta : Integer);
|
|
var
|
|
SaveD : LongInt;
|
|
begin
|
|
SaveD := lHDelta;
|
|
if Delta < 0 then
|
|
if Delta > lHDelta then
|
|
lHDelta := 0
|
|
else
|
|
Inc(lHDelta, Delta)
|
|
else
|
|
if LongInt(lHDelta)+Delta > LongInt(FColumns) then
|
|
lHDelta := FColumns
|
|
else
|
|
Inc(lHDelta, Delta);
|
|
|
|
if lhDelta < 0 then
|
|
lhDelta := 0;
|
|
|
|
if lHDelta <> SaveD then begin
|
|
vlbSetHScrollPos;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbInitScrollInfo;
|
|
{-setup scroll bar range and initial position}
|
|
begin
|
|
if not HandleAllocated then
|
|
Exit;
|
|
|
|
{initialize scroll bars, if any}
|
|
vlbSetVScrollRange;
|
|
vlbSetVScrollPos;
|
|
vlbSetHScrollRange;
|
|
vlbSetHScrollPos;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbMakeItemVisible(Index : LongInt);
|
|
{-make sure the item is visible}
|
|
begin
|
|
if Index < FTopIndex then
|
|
TopIndex := Index
|
|
else if Index+LongInt($80000000) > (FTopIndex+Pred(lRows))+LongInt($80000000) then begin
|
|
TopIndex := Index-Pred(lRows);
|
|
if FTopIndex < 0 then
|
|
TopIndex := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbNewActiveItem(Index : LongInt);
|
|
{-set the currently selected item}
|
|
begin
|
|
{verify valid index}
|
|
if Index < 0 then
|
|
Index := 0
|
|
else if Index > lHighIndex then
|
|
Index := lHighIndex;
|
|
|
|
{set the newly selected item index}
|
|
FItemIndex := Index;
|
|
vlbMakeItemVisible(Index);
|
|
DoOnSelect(Index, True);
|
|
InvalidateItem(Index);
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.vlbScaleDown(N : LongInt) : Integer;
|
|
begin
|
|
Result := N div lDivisor;
|
|
end;
|
|
|
|
function TOvcCustomVirtualListBox.vlbScaleUp(N : LongInt) : LongInt;
|
|
begin
|
|
Result := N * lDivisor;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbSelectRangePrim(First, Last : LongInt; Select : Boolean);
|
|
{-change the selection for the given range of indexes}
|
|
var
|
|
I : LongInt;
|
|
begin
|
|
if First <= Last then begin
|
|
for I := First to Last do begin
|
|
DoOnSelect(I, Select);
|
|
InvalidateItem(I);
|
|
end;
|
|
end else begin
|
|
for I := First downto Last do begin
|
|
DoOnSelect(I, Select);
|
|
InvalidateItem(I);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbSetAllItemsPrim(Select : Boolean);
|
|
{-primitive routine thats acts on all items}
|
|
var
|
|
I : LongInt;
|
|
LastIndex : LongInt;
|
|
begin
|
|
{determine highest index to test}
|
|
LastIndex := FTopIndex+Pred(lRows);
|
|
if LastIndex > Pred(FNumItems) then
|
|
LastIndex := Pred(FNumItems);
|
|
|
|
{invalidate items that require repainting}
|
|
for I := FTopIndex to LastIndex do
|
|
if DoOnIsSelected(I) <> Select then
|
|
InvalidateItem(I);
|
|
|
|
{select or deselect all items}
|
|
DoOnSelect(-1, Select);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbSetFocusedIndex(Index : LongInt);
|
|
{-set focus index to this item. invalidate previous}
|
|
begin
|
|
if Index <> lFocusedIndex then begin
|
|
InvalidateItem(lFocusedIndex);
|
|
|
|
lFocusedIndex := Index;
|
|
InvalidateItem(lFocusedIndex);
|
|
end;
|
|
end;
|
|
|
|
{ rewritten - see below
|
|
procedure TOvcCustomVirtualListBox.vlbSetHScrollPos;
|
|
begin
|
|
if lHaveHS then
|
|
SetScrollPos(Handle, SB_HORZ, lHDelta, True);
|
|
end;
|
|
}
|
|
|
|
{ rewritten}
|
|
procedure TOvcCustomVirtualListBox.vlbSetHScrollPos;
|
|
var
|
|
SI : TScrollInfo;
|
|
begin
|
|
if lHaveHS and HandleAllocated then begin
|
|
with SI do begin
|
|
cbSize := SizeOf(SI);
|
|
fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
|
|
nMin := 0;
|
|
nMax := FColumns;
|
|
nPage := FColumns div 2;
|
|
nPos := lhDelta;
|
|
nTrackPos := nPos;
|
|
end;
|
|
SetScrollInfo(Handle, SB_HORZ, SI, True);
|
|
end;
|
|
end;
|
|
|
|
{ rewritten - see below
|
|
procedure TOvcCustomVirtualListBox.vlbSetHScrollRange;
|
|
begin
|
|
if lHaveHS then
|
|
SetScrollRange(Handle, SB_HORZ, 0, FColumns, False);
|
|
end;
|
|
}
|
|
|
|
{ rewritten}
|
|
procedure TOvcCustomVirtualListBox.vlbSetHScrollRange;
|
|
{var
|
|
SI : TScrollInfo;}
|
|
begin
|
|
vlbSetHScrollPos;
|
|
(*
|
|
if lHaveHS then
|
|
begin
|
|
with SI do
|
|
begin
|
|
fMask := {SIF_PAGE + }SIF_RANGE;
|
|
nMin := 1;
|
|
nMax := FColumns - ClientWidth;
|
|
//nPage := nMax div 10;
|
|
cbSize := SizeOf(SI);
|
|
end;
|
|
SetScrollInfo(Handle, SB_HORZ, SI, False);
|
|
end;
|
|
*)
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbSetSelRange(First, Last : LongInt);
|
|
{-set the selection on for the given range of indexes}
|
|
begin
|
|
vlbSelectRangePrim(First, Last, True);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbSetVScrollPos;
|
|
var
|
|
SI : TScrollInfo;
|
|
begin
|
|
if not HandleAllocated then
|
|
Exit;
|
|
with SI do begin
|
|
cbSize := SizeOf(SI);
|
|
fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
|
|
nMin := 0;
|
|
nMax := Pred(lVSHigh);
|
|
nPage := lRows;
|
|
nPos := vlbScaleDown(FTopIndex);
|
|
nTrackPos := nPos;
|
|
end;
|
|
SetScrollInfo(Handle, SB_VERT, SI, True);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbSetVScrollRange;
|
|
var
|
|
ItemRange : LongInt;
|
|
begin
|
|
ItemRange := FNumItems;
|
|
lDivisor := 1;
|
|
if ItemRange < lRows then
|
|
lVSHigh := 1
|
|
{$IFDEF MSWINDOWS}
|
|
else if ItemRange <= High(SmallInt) then
|
|
lVSHigh := ItemRange
|
|
else begin
|
|
lDivisor := 2*(ItemRange div 32768);
|
|
lVSHigh := ItemRange div lDivisor;
|
|
end;
|
|
{$ELSE} //lDivisor not needed apparently (and causes clicks to scroll >1 item).
|
|
else
|
|
lVSHigh := ItemRange;
|
|
{$ENDIF}
|
|
|
|
if lHaveVS then
|
|
if not ((FNumItems > lRows) or (csDesigning in ComponentState)) then
|
|
lvSHigh := 0
|
|
else
|
|
else
|
|
lvSHigh := 0;
|
|
vlbSetVScrollPos;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbToggleSelection(Index : LongInt);
|
|
{-process Ctrl-LMouseBtn}
|
|
var
|
|
WasSelected : Boolean;
|
|
begin
|
|
if (Index < 0) or (Index > lHighIndex) then
|
|
exit;
|
|
{toggle highlight}
|
|
WasSelected := DoOnIsSelected(Index);
|
|
DoOnSelect(Index, not WasSelected);
|
|
vlbSetFocusedIndex(Index);
|
|
DrawItem(Index);
|
|
{set new active item}
|
|
FItemIndex := Index;
|
|
{and anchor point}
|
|
lAnchor := Index;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbValidateItem(Index : LongInt);
|
|
{-validate the area for this item}
|
|
var
|
|
CR : TRect;
|
|
begin
|
|
if (Index >= FTopIndex) and (Index-FTopIndex < lRows) then begin {visible?}
|
|
CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, 0);
|
|
CR.Bottom := CR.Top+FRowHeight;
|
|
ValidateRect(Handle, @CR);
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.vlbVScrollPrim(Delta : Integer);
|
|
var
|
|
I : LongInt;
|
|
begin
|
|
I := FTopIndex+Delta;
|
|
if I < 0 then
|
|
if Delta > 0 then
|
|
I := lHighIndex
|
|
else
|
|
I := 0
|
|
else if (I > lHighIndex-Pred(lRows)) then begin
|
|
if lHighIndex > Pred(lRows) then
|
|
I := lHighIndex-Pred(lRows)
|
|
else
|
|
I := 0;
|
|
end;
|
|
|
|
SetTopIndex(I);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMChar(var Msg : TWMChar);
|
|
var
|
|
L : LongInt;
|
|
begin
|
|
inherited;
|
|
|
|
L := DoOnCharToItem(AnsiChar(Msg.CharCode));
|
|
if (L >= 0) and (L <= lHighIndex) then
|
|
SetItemIndex(L);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMEraseBkgnd(var Msg : TWMEraseBkGnd);
|
|
begin
|
|
{indicate that we have processed this message}
|
|
Msg.Result := 1;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMGetDlgCode(var Msg : TWMGetDlgCode);
|
|
begin
|
|
inherited;
|
|
|
|
Msg.Result := Msg.Result or DLGC_WANTCHARS or DLGC_WANTARROWS;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMHScroll(var Msg : TWMHScroll);
|
|
begin
|
|
case Msg.ScrollCode of
|
|
SB_LINERIGHT : vlbHScrollPrim(+1);
|
|
SB_LINELEFT : vlbHScrollPrim(-1);
|
|
SB_PAGERIGHT : vlbHScrollPrim(+10);
|
|
SB_PAGELEFT : vlbHScrollPrim(-10);
|
|
SB_THUMBPOSITION, SB_THUMBTRACK :
|
|
if lHDelta <> Msg.Pos then begin
|
|
lHDelta := Msg.Pos;
|
|
vlbSetHScrollPos;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMKeyDown(var Msg : TWMKeyDown);
|
|
var
|
|
I : LongInt;
|
|
Cmd : Word;
|
|
begin
|
|
inherited;
|
|
|
|
Cmd := Controller.EntryCommands.Translate(TMessage(Msg));
|
|
if Cmd <> ccNone then begin
|
|
|
|
{filter invalid commands}
|
|
case Cmd of
|
|
ccExtendHome, ccExtendEnd, ccExtendPgUp,
|
|
ccExtendPgDn, ccExtendUp, ccExtendDown :
|
|
if not FMultiSelect then
|
|
Exit;
|
|
end;
|
|
|
|
case Cmd of
|
|
ccLeft :
|
|
if lHaveHs then begin
|
|
if lHDelta > 0 then begin
|
|
Dec(lHDelta);
|
|
vlbSetHScrollPos;
|
|
Refresh;
|
|
end;
|
|
end else begin
|
|
if FItemIndex > 0 then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(FItemIndex-1);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
end;
|
|
ccRight :
|
|
if lHaveHs then begin
|
|
if lHDelta < FColumns then begin
|
|
Inc(lHDelta);
|
|
vlbSetHScrollPos;
|
|
Refresh;
|
|
end;
|
|
end else begin
|
|
if FItemIndex < lHighIndex then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(FItemIndex+1);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
end;
|
|
ccUp :
|
|
if FItemIndex > 0 then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(FItemIndex-1);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
ccDown :
|
|
if FItemIndex < lHighIndex then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(FItemIndex+1);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
ccHome :
|
|
if FItemIndex <> 0 then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(0);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
ccEnd :
|
|
if (FNumItems > 0) and (FItemIndex <> lHighIndex) then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(lHighIndex);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
ccPrevPage :
|
|
if FNumItems > 0 then begin
|
|
if lRows = 1 then
|
|
I := Pred(FItemIndex)
|
|
else
|
|
I := FItemIndex-Pred(lRows);
|
|
if I < 0 then
|
|
I := 0;
|
|
if I <> FItemIndex then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(I);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
end;
|
|
ccNextPage :
|
|
if FNumItems > 0 then begin
|
|
if lRows = 1 then begin
|
|
if FItemIndex < lHighIndex then
|
|
I := Succ(FItemIndex)
|
|
else
|
|
I := lHighIndex;
|
|
end else if FItemIndex <= lHighIndex-Pred(lRows) then
|
|
I := FItemIndex+Pred(lRows)
|
|
else
|
|
I := lHighIndex;
|
|
if I <> FItemIndex then begin
|
|
vlbClearAllItems;
|
|
SetItemIndex(I);
|
|
lAnchor := FItemIndex;
|
|
end;
|
|
end;
|
|
ccExtendHome :
|
|
if FItemIndex > 0 then begin
|
|
vlbNewActiveItem(0);
|
|
vlbExtendSelection(0);
|
|
end;
|
|
ccExtendEnd :
|
|
if FItemIndex < lHighIndex then begin
|
|
vlbNewActiveItem(lHighIndex);
|
|
vlbExtendSelection(lHighIndex);
|
|
end;
|
|
ccExtendPgUp :
|
|
begin
|
|
I := FItemIndex-Pred(lRows);
|
|
vlbNewActiveItem(I);
|
|
vlbExtendSelection(I);
|
|
end;
|
|
ccExtendPgDn :
|
|
begin
|
|
I := FItemIndex+Pred(lRows);
|
|
vlbNewActiveItem(I);
|
|
vlbExtendSelection(I);
|
|
end;
|
|
ccExtendUp :
|
|
begin
|
|
I := FItemIndex-1;
|
|
vlbNewActiveItem(I);
|
|
vlbExtendSelection(I);
|
|
end;
|
|
ccExtendDown :
|
|
begin
|
|
I := FItemIndex+1;
|
|
vlbNewActiveItem(I);
|
|
vlbExtendSelection(I);
|
|
end;
|
|
else
|
|
{do user command notification for user commands}
|
|
if Cmd >= ccUserFirst then
|
|
DoOnUserCommand(Cmd);
|
|
end;
|
|
|
|
{indicate that this message was processed}
|
|
Msg.Result := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMKillFocus(var Msg : TWMKillFocus);
|
|
begin
|
|
inherited;
|
|
|
|
{re-draw focused item to erase focus rect}
|
|
DrawItem(lFocusedIndex);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMLButtonDown(var Msg : TWMLButtonDown);
|
|
var
|
|
I : LongInt;
|
|
LastI : LongInt;
|
|
LButton : Byte;
|
|
CtrlKeyDown : Boolean;
|
|
ShiftKeyDown : Boolean;
|
|
|
|
function PointToIndex : LongInt;
|
|
var
|
|
Pt : TPoint;
|
|
begin
|
|
GetCursorPos(Pt);
|
|
Pt := ScreenToClient(Pt);
|
|
if Pt.Y < Ord(FShowHeader)*FRowHeight then begin
|
|
{speed up as the cursor moves farther away}
|
|
Result := FTopIndex+(Pt.Y div FRowHeight)-1;
|
|
if Result < 0 then
|
|
Result := 0;
|
|
end else if Pt.Y >= ClientHeight then begin
|
|
{speed up as the cursor moves farther away}
|
|
Result := FTopIndex+(Pt.Y div FRowHeight);
|
|
if Result > lHighIndex then
|
|
Result := lHighIndex;
|
|
end else begin
|
|
{convert to an index}
|
|
Result := FTopIndex-Ord(FShowHeader)+(Pt.Y div FRowHeight);
|
|
if ClientHeight mod FRowHeight > 0 then
|
|
if Result > FTopIndex-1 + lRows then
|
|
Result := FTopIndex-1 + lRows;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
ItemNo : Integer;
|
|
ShiftState: TShiftState;
|
|
begin
|
|
ShiftState := KeysToShiftState(Msg.Keys);
|
|
if (DragMode = dmAutomatic) and FMultiSelect then
|
|
begin
|
|
if not (ssShift in ShiftState) or (ssCtrl in ShiftState) then
|
|
begin
|
|
ItemNo := ItemAtPos(SmallPointToPoint(Msg.Pos), True);
|
|
if (ItemNo >= 0) and (DoOnIsSelected(ItemNo)) then
|
|
begin
|
|
BeginDrag (False);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
inherited;
|
|
if (DragMode = dmAutomatic) and not (FMultiSelect and
|
|
((ssCtrl in ShiftState) or (ssShift in ShiftState))) then
|
|
BeginDrag(False);
|
|
|
|
if MousePassThru then exit;
|
|
|
|
{solve problem with minimized modeless dialogs and MDI child windows}
|
|
{that contain virtual ListBox components}
|
|
if not Focused and CanFocus then
|
|
{$IFNDEF LCL}
|
|
Windows.SetFocus(Handle);
|
|
{$ELSE}
|
|
LclIntf.SetFocus(Handle);
|
|
{$ENDIF}
|
|
|
|
{is this click on the header?}
|
|
if FShowHeader and (Msg.YPos < FRowHeight) then begin
|
|
DoOnClickHeader(Point(Msg.XPos, Msg.YPos));
|
|
Exit;
|
|
end;
|
|
|
|
if (FNumItems <> 0) then begin
|
|
{get the actual left button}
|
|
LButton := GetLeftButton;
|
|
|
|
{get the key state}
|
|
if FMultiSelect then begin
|
|
{$IFNDEF LCLCarbon}
|
|
CtrlKeyDown := GetKeyState(VK_CONTROL) and $8000 <> 0;
|
|
{$ELSE} {Cmd+click used on Mac for non-contiguous selection; see it as VK_LWIN}
|
|
CtrlKeyDown := GetKeyState(VK_LWIN) and $8000 <> 0;
|
|
{$ENDIF}
|
|
ShiftKeyDown := GetKeyState(VK_SHIFT) and $8000 <> 0;
|
|
end else begin
|
|
CtrlKeyDown := False;
|
|
ShiftKeyDown := False;
|
|
end;
|
|
|
|
if CtrlKeyDown then
|
|
vlbToggleSelection(PointToIndex)
|
|
else if ShiftKeyDown then
|
|
vlbExtendSelection(PointToIndex)
|
|
else begin
|
|
vlbClearAllItems;
|
|
|
|
{reselect the active item}
|
|
if FItemIndex <> -1 then begin
|
|
DoOnSelect(FItemIndex, True);
|
|
vlbSetFocusedIndex(FItemIndex);
|
|
end;
|
|
|
|
{watch the mouse position while the left button is down}
|
|
LastI := -1;
|
|
repeat
|
|
I := PointToIndex;
|
|
if I <= lHighIndex then
|
|
if not FMultiSelect or (LastI = -1) then begin
|
|
SetItemIndex(I);
|
|
lAnchor := I;
|
|
LastI := I;
|
|
end else begin
|
|
{extend/shrink the selection to follow the mouse}
|
|
if I <> LastI then begin
|
|
vlbDragSelection(lAnchor, I);
|
|
LastI := I;
|
|
end;
|
|
end;
|
|
Application.ProcessMessages; {Gasp}
|
|
{$IFDEF MSWINDOWS}
|
|
until ({$IFNDEF LCL} GetAsyncKeyState(LButton) {$ELSE} GetKeyState(LButton) {$ENDIF} and $8000 = 0)
|
|
{$ELSE} //GTK GetKeyState returns 0
|
|
until (not (csLButtonDown in ControlState))
|
|
{$ENDIF}
|
|
or Dragging or (GetCapture <> Handle);
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMLButtonDblClk(var Msg : TWMLButtonDblClk);
|
|
begin
|
|
{is this click below the header, if any}
|
|
if (Msg.YPos > FRowHeight * Ord(FShowHeader)) then
|
|
inherited
|
|
else
|
|
{say we processed this message}
|
|
Msg.Result := 0;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMMouseActivate(var Msg : TWMMouseActivate);
|
|
begin
|
|
if (csDesigning in ComponentState) or (GetFocus = Handle) then
|
|
inherited
|
|
else begin
|
|
if Controller.ErrorPending then
|
|
Msg.Result := MA_NOACTIVATEANDEAT
|
|
else
|
|
Msg.Result := MA_ACTIVATE;
|
|
end;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMSetFocus(var Msg : TWMSetFocus);
|
|
begin
|
|
inherited;
|
|
|
|
Update;
|
|
DrawItem(lFocusedIndex);
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMSize(var Msg : TWMSize);
|
|
begin
|
|
if FRowHeight > 0 then begin
|
|
{integral font height adjustment}
|
|
vlbCalcFontFields;
|
|
vlbAdjustIntegralHeight;
|
|
{$IFDEF LCL} //Make sure calling code knows about any change in height.
|
|
if (csDesigning in ComponentState) and
|
|
not (csLoading in ComponentState) then
|
|
if FIntegralHeight then
|
|
Msg.Height := Height; //was ClientHeight, but no longer works on Windows
|
|
{$ENDIF}
|
|
vlbCalcFontFields;
|
|
vlbInitScrollInfo;
|
|
|
|
{reposition so that items are displayed at bottom of list}
|
|
if lRows + FTopIndex - 1 >= FNumItems then
|
|
if NumItems-lRows >= 0 then
|
|
TopIndex := NumItems-lRows
|
|
else
|
|
TopIndex := 0;
|
|
end;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TOvcCustomVirtualListBox.WMVScroll(var Msg : TWMVScroll);
|
|
var
|
|
I : LongInt;
|
|
begin
|
|
case Msg.ScrollCode of
|
|
SB_LINEUP : vlbVScrollPrim(-1);
|
|
SB_LINEDOWN : vlbVScrollPrim(+1);
|
|
SB_PAGEDOWN : vlbVScrollPrim(+Pred(lRows));
|
|
SB_PAGEUP : vlbVScrollPrim(-Pred(lRows));
|
|
SB_THUMBPOSITION, SB_THUMBTRACK :
|
|
begin
|
|
if Msg.Pos = 0 then
|
|
I := 0
|
|
else if Msg.Pos = lVSHigh then
|
|
if lRows >= FNumItems then
|
|
I := 0
|
|
else
|
|
I := lHighIndex-Pred(lRows)
|
|
else
|
|
I := vlbScaleUp(Msg.Pos);
|
|
ForceTopIndex(I,True);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ new}
|
|
procedure TOvcCustomVirtualListBox.SetColumns(const Value: Integer);
|
|
begin
|
|
if Value <> FColumns then begin
|
|
FColumns := Value;
|
|
vlbInitScrollInfo;
|
|
end;
|
|
end;
|
|
|
|
end.
|