{*********************************************************} {* 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.