mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-06-25 02:28:25 +02:00
526 lines
18 KiB
PHP
526 lines
18 KiB
PHP
// included by stdctrls.pp
|
|
{
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.LCL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
{ if not HandleAllocated then
|
|
FItems contains a TExtendedStringList
|
|
else
|
|
FItems contains an interface specific TStrings descendent
|
|
}
|
|
|
|
type
|
|
TCustomListBoxItemRecord = record
|
|
TheObject: TObject;
|
|
Selected: Boolean;
|
|
end;
|
|
PCustomListBoxItemRecord = ^TCustomListBoxItemRecord;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.AssignCacheToItemData }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.AssignCacheToItemData(const AIndex: Integer; const AData: Pointer);
|
|
begin
|
|
if PCustomListBoxItemRecord(AData)^.Selected
|
|
or (FItemIndex = AIndex)
|
|
then SendItemSelected(AIndex, True);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.AssignItemDataToCache }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.AssignItemDataToCache(const AIndex: Integer; const AData: Pointer);
|
|
begin
|
|
PCustomListBoxItemRecord(AData)^.Selected := Selected[AIndex];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.CreateHandle
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.CreateHandle;
|
|
var
|
|
NewStrings : TStrings;
|
|
i, cnt: integer;
|
|
OldItems: TExtendedStringList;
|
|
begin
|
|
//writeln('[TCustomListBox.CreateHandle] A ',FItems.ClassName);
|
|
inherited CreateHandle;
|
|
//writeln('[TCustomListBox.CreateHandle] B ',FItems.ClassName);
|
|
// create
|
|
CNSendMessage(LM_SETBORDER, Self, nil);
|
|
|
|
// fetch the interface item list
|
|
NewStrings:= TStrings(Pointer(CNSendMessage(LM_GETITEMS, Self, nil)));
|
|
// copy the items (text+objects)
|
|
NewStrings.Assign(Items);
|
|
OldItems := FItems as TExtendedStringList;
|
|
|
|
// new item list is the interface item list
|
|
FItems:= NewStrings;
|
|
FCacheValid := False;
|
|
|
|
CNSendMessage(LM_SETITEMINDEX, Self, Pointer(FItemIndex));
|
|
|
|
// copy items attributes
|
|
cnt := OldItems.Count;
|
|
for i:=0 to cnt-1 do
|
|
AssignCacheToItemData(i, OldItems.Records[i]);
|
|
|
|
// free old items
|
|
OldItems.Free;
|
|
|
|
//writeln('[TCustomListBox.CreateHandle] END ',FItems.ClassName);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.DestroyHandle }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.DestroyHandle;
|
|
var
|
|
NewStrings : TExtendedStringList;
|
|
i, Cnt: integer;
|
|
begin
|
|
//writeln('[TCustomListBox.DestroyHandle] A ',FItems.ClassName);
|
|
// create internal item list
|
|
NewStrings:= TExtendedStringList.Create(GetCachedDataSize);
|
|
|
|
// copy items (text+objects) from the interface items list
|
|
NewStrings.Assign(Items);
|
|
// copy items attributes
|
|
Cnt:=Items.Count;
|
|
for i:=0 to Cnt-1 do
|
|
AssignItemDataToCache(i, NewStrings.Records[i]);
|
|
|
|
// free the interface items list
|
|
FItems.Free;
|
|
// new item list is the internal item list
|
|
FItems:= NewStrings;
|
|
FCacheValid := True;
|
|
//writeln('[TCustomListBox.DestroyHandle] B ',FItems.ClassName);
|
|
inherited DestroyHandle;
|
|
//writeln('[TCustomListBox.DestroyHandle] END ',FItems.ClassName);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.SetBorderStyle }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetBorderStyle(Val : TBorderStyle);
|
|
begin
|
|
if FBorderStyle <> Val then begin
|
|
FBorderStyle:= Val;
|
|
if HandleAllocated then CNSendMessage(LM_SETBORDER, Self, nil);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.UpdateSelectionMode }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.UpdateSelectionMode;
|
|
var
|
|
Msg : TLMSetSelMode;
|
|
begin
|
|
if not HandleAllocated then exit;
|
|
Msg.ExtendedSelect:= ExtendedSelect;
|
|
Msg.MultiSelect:= MultiSelect;
|
|
CNSendMessage(LM_SETSELMODE, Self, @Msg);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TCustomListBox.GetTopIndex: Integer;
|
|
------------------------------------------------------------------------------}
|
|
function TCustomListBox.GetTopIndex: Integer;
|
|
begin
|
|
if HandleAllocated then
|
|
FTopIndex:=CNSendMessage(LM_LB_GETTOPINDEX, Self, nil);
|
|
Result := FTopIndex;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.SetTopIndex(const AValue: Integer);
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetTopIndex(const AValue: Integer);
|
|
begin
|
|
// don't check if changed. If the item is only partly visible, the message
|
|
// will make it complete visible.
|
|
FTopIndex:=AValue;
|
|
if HandleAllocated and ([csLoading,csDestroying]*ComponentState=[]) then
|
|
CNSendMessage(LM_LB_SETTOPINDEX, Self, Pointer(FTopIndex));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.UpdateSorted;
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.UpdateSorted;
|
|
var AMessage : TLMSort;
|
|
begin
|
|
if not HandleAllocated then exit;
|
|
with AMessage do begin
|
|
Msg:= LM_SORT;
|
|
List:= FItems;
|
|
IsSorted:= FSorted;
|
|
end;
|
|
CNSendMessage(LM_SORT, Self, @AMessage);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.LMDrawListItem(var TheMessage: TLMDrawListItem);
|
|
|
|
Handler for custom drawing items.
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.LMDrawListItem(var TheMessage: TLMDrawListItem);
|
|
begin
|
|
with TheMessage.DrawListItemStruct^ do
|
|
begin
|
|
FCanvas.Handle := DC;
|
|
if Font<>nil then
|
|
FCanvas.Font := Font;
|
|
if Brush<>nil then
|
|
FCanvas.Brush := Brush;
|
|
if (ItemID >= 0) and (odSelected in ItemState) then
|
|
begin
|
|
FCanvas.Brush.Color := clHighlight;
|
|
FCanvas.Font.Color := clHighlightText
|
|
end else begin
|
|
FCanvas.Brush.Color:=clWindow;
|
|
FCanvas.Font.Color:=clWindowText;
|
|
end;
|
|
DrawItem(ItemID, Area, ItemState);
|
|
if odFocused in ItemState then
|
|
{DrawFocusRect(hDC, rcItem)};
|
|
FCanvas.Handle := 0;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.SendItemSelected(Index: integer; IsSelected: boolean);
|
|
|
|
Tell the interface whether an item is selected.
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SendItemSelected(Index: integer; IsSelected: boolean);
|
|
var
|
|
Msg : TLMSetSel;
|
|
begin
|
|
if HandleAllocated then begin
|
|
Msg.Index:= Index;
|
|
Msg.Selected:= IsSelected;
|
|
CNSendMessage(LM_SETSEL, Self, @Msg);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.SetExtendedSelect }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetExtendedSelect(Val : boolean);
|
|
begin
|
|
if Val <> FExtendedSelect then begin
|
|
FExtendedSelect:= Val;
|
|
UpdateSelectionMode;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.SetMultiSelect }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetMultiSelect(Val : boolean);
|
|
begin
|
|
if Val <> FMultiSelect then begin
|
|
FMultiSelect:= Val;
|
|
UpdateSelectionMode;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.SetSelected }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetSelected(Index : integer; Val : boolean);
|
|
begin
|
|
CheckIndex(Index);
|
|
|
|
if not MultiSelect then begin
|
|
if Val then
|
|
ItemIndex:=Index
|
|
else if Index=ItemIndex then
|
|
ItemIndex:=-1;
|
|
end else begin
|
|
if HandleAllocated
|
|
then SendItemSelected(Index,Val)
|
|
else PCustomListBoxItemRecord(GetCachedData(Index))^.Selected := Val;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.GetSelected }
|
|
{------------------------------------------------------------------------------}
|
|
function TCustomListBox.GetSelected(Index : integer) : boolean;
|
|
begin
|
|
CheckIndex(Index);
|
|
if HandleAllocated then
|
|
Result:= (CNSendMessage(LM_GETSEL, Self, @Index) > 0)
|
|
else
|
|
Result:= PCustomListBoxItemRecord(GetCachedData(Index))^.Selected;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.GetSelCount }
|
|
{------------------------------------------------------------------------------}
|
|
function TCustomListBox.GetSelCount : integer;
|
|
begin
|
|
if HandleAllocated then
|
|
Result:= CNSendMessage(LM_GETSELCOUNT, Self, nil)
|
|
else
|
|
Result:=0;
|
|
end;
|
|
|
|
function TCustomListBox.GetItemHeight: Integer;
|
|
begin
|
|
Result := FItemHeight;
|
|
end;
|
|
|
|
procedure TCustomListBox.SetItemHeight(Value: Integer);
|
|
begin
|
|
if (FItemHeight <> Value) and (Value > 0) then begin
|
|
FItemHeight := Value;
|
|
if (not HandleAllocated) or (csLoading in ComponentState) then exit;
|
|
RecreateWnd;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.SetSorted }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetSorted(Val : boolean);
|
|
begin
|
|
if Val <> FSorted then begin
|
|
FSorted:= Val;
|
|
UpdateSorted;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ procedure TCustomListBox.SetStyle }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetStyle(Val : TListBoxStyle);
|
|
begin
|
|
if Val <> FStyle then begin
|
|
FStyle:= Val;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomListBox.DrawItem(Index: Integer; ARect: TRect;
|
|
State: TOwnerDrawState);
|
|
{var
|
|
Flags: Longint;
|
|
Data: String;}
|
|
begin
|
|
if Assigned(FOnDrawItem) then
|
|
FOnDrawItem(Self, Index, ARect, State)
|
|
else if not (odPainted in State) then
|
|
begin
|
|
FCanvas.FillRect(ARect);
|
|
if (Index>=0) and (Index < Items.Count) then
|
|
begin
|
|
{Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
|
|
if not UseRightToLeftAlignment then
|
|
Inc(Rect.Left, 2)
|
|
else
|
|
Dec(Rect.Right, 2);
|
|
Data := '';
|
|
if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
|
|
Data := DoGetData(Index)
|
|
else
|
|
Data := Items[Index];
|
|
DrawText(FCanvas.Handle, PChar(Data), Length(Data), Rect, Flags);}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.GetCachedData }
|
|
{------------------------------------------------------------------------------}
|
|
function TCustomListBox.GetCachedData(const AIndex: Integer): Pointer;
|
|
begin
|
|
if not FCacheValid then raise EInvalidOperation.Create('Reading form invalid cache');
|
|
Result := TExtendedStringList(FItems).Records[AIndex];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.GetCachedDataSize }
|
|
{ }
|
|
{ Returns the amount of data needed when the widged isn't realized in the }
|
|
{ interface }
|
|
{------------------------------------------------------------------------------}
|
|
function TCustomListBox.GetCachedDataSize: Integer;
|
|
begin
|
|
Result := SizeOf(TCustomListBoxItemRecord);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.SetItems }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.SetItems(Value : TStrings);
|
|
begin
|
|
if (Value <> FItems) then begin
|
|
//writeln('[TCustomListBox.SetItems] A FItems=',FItems.ClassName,' Value=',Value.ClassName);
|
|
FItems.Assign(Value);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.Create }
|
|
{------------------------------------------------------------------------------}
|
|
constructor TCustomListBox.Create(AOwner : TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
fCompStyle := csListBox;
|
|
FBorderStyle:= bsSingle;
|
|
FItems := TExtendedStringList.Create(GetCachedDataSize);
|
|
FCacheValid := True;
|
|
FItemIndex:=-1;
|
|
FCanvas := TControlCanvas.Create;
|
|
TControlCanvas(FCanvas).Control := Self;
|
|
ParentColor := false;
|
|
TabStop := true;
|
|
SetInitialBounds(0, 0, 100, 80);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ function TCustomListBox.Destroy }
|
|
{------------------------------------------------------------------------------}
|
|
destructor TCustomListBox.Destroy;
|
|
begin
|
|
Destroying;
|
|
DestroyWnd;
|
|
FreeAndNil(FCanvas);
|
|
inherited Destroy;
|
|
FreeAndNil(FItems);
|
|
end;
|
|
|
|
function TCustomListBox.GetItemIndex : integer;
|
|
begin
|
|
//writeln('[TCustomListBox.GetItemIndex] A ',FItems.ClassName);
|
|
if HandleAllocated then begin
|
|
Result:= CNSendMessage(LM_GETITEMINDEX, Self, nil);
|
|
FItemIndex:=Result;
|
|
end else
|
|
Result:=FItemIndex;
|
|
//writeln('[TCustomListBox.GetItemIndex] END ');
|
|
end;
|
|
|
|
procedure TCustomListBox.SetItemIndex(Val : integer);
|
|
begin
|
|
if (Val >= FItems.Count) then
|
|
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Val,FItems.Count]);
|
|
if Val<0 then Val:=-1;
|
|
//writeln('[TCustomListBox.SetItemIndex] A ',FItems.ClassName,' ',Val);
|
|
FItemIndex:=Val;
|
|
if HandleAllocated then
|
|
CNSendMessage(LM_SETITEMINDEX, Self, Pointer(Val));
|
|
//writeln('[TCustomListBox.SetItemIndex] END ',FItems.ClassName);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.CheckIndex
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.CheckIndex(const AIndex: Integer);
|
|
begin
|
|
if (AIndex < 0)
|
|
or (AIndex >= Items.Count)
|
|
then raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName, AIndex, Items.Count]);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TCustomListBox.Clear
|
|
|
|
Delete all items.
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomListBox.Clear;
|
|
begin
|
|
FItems.Clear;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TCustomListBox.GetIndexAtY(Y: integer): integer;
|
|
|
|
Returns item index at y coordinate (including scrolling)
|
|
------------------------------------------------------------------------------}
|
|
function TCustomListBox.GetIndexAtY(Y: integer): integer;
|
|
begin
|
|
Result:=-1;
|
|
if (not HandleAllocated) then exit;
|
|
Result:=GetListBoxIndexAtY(Self, Y);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TCustomListBox.ItemAtPos(const Pos: TPoint; Existing: Boolean
|
|
): Integer;
|
|
|
|
Returns item index at y coordinate (including scrolling)
|
|
------------------------------------------------------------------------------}
|
|
function TCustomListBox.ItemAtPos(const Pos: TPoint; Existing: Boolean
|
|
): Integer;
|
|
begin
|
|
Result:=GetIndexAtY(Pos.Y);
|
|
if Existing then begin
|
|
if Result>=Items.Count then Result:=-1;
|
|
end else begin
|
|
if (Result<0) and (Result>Items.Count) and PtInRect(ClientRect,Pos) then
|
|
Result:=Items.Count;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TCustomListBox.ItemRect(Index: Integer): TRect;
|
|
|
|
Returns coordinates of an item (including scrolling)
|
|
Special: If Index=Count the rectangle is guessed (like VCL).
|
|
------------------------------------------------------------------------------}
|
|
function TCustomListBox.ItemRect(Index: Integer): TRect;
|
|
begin
|
|
if (Index>=0) and (Index<Items.Count) then begin
|
|
GetListBoxItemRect(Self,Index,Result);
|
|
end else if (Index=Items.Count) and (Index>0) then begin
|
|
GetListBoxItemRect(Self,Index-1,Result);
|
|
OffsetRect(Result,0,Result.Bottom-Result.Top);
|
|
end else begin
|
|
FillChar(Result,SizeOf(Result),0);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TCustomListBox.ItemVisible(Index: Integer): boolean;
|
|
|
|
Returns true if Item is visible.
|
|
------------------------------------------------------------------------------}
|
|
function TCustomListBox.ItemVisible(Index: Integer): boolean;
|
|
var
|
|
ARect: TRect;
|
|
begin
|
|
Result:=false;
|
|
if (Index<0) or (Index>=Items.Count) then exit;
|
|
if not GetListBoxItemRect(Self,Index,ARect) then exit;
|
|
if (ARect.Bottom<0) or (ARect.Top>ClientHeight) then exit;
|
|
Result:=true;
|
|
end;
|
|
|
|
procedure TCustomListBox.MakeCurrentVisible;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i:=ItemIndex;
|
|
if (i<0) or (i>=Items.Count) then exit;
|
|
TopIndex:=ItemIndex;
|
|
end;
|
|
|
|
|
|
// back to stdctrls.pp
|