Problem klas delphi na lazarusa

0

W delphi 7 działa poprawnie z tym poniżej, gdzie oryginalnie jest Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); bez flags nie pozwala podświetlić na niebiesko itemów.

Flags := DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX; // kompiluje się w lazarusie
 // zamiast
 //Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);

Dopiero sprawdzę w lazarusie, gdy zastosuję TOwnerDrawState - nadal szukam.

Chodzi mi @furious programming o to, że:

var
  State: TOwnerDrawState; // zmienną kompiluje
 begin
  State := TOwnerDrawState(LongRec(itemState).Lo); // Nie rozpoznaje w begin TOwnerDrawState w lazarusie

W obrazku ex1 w delphi, gdy:

  Flags := DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX; // kompiluje się w lazarusie
  // lub
  //Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);

bez Flags tak jak na obrazku ex2.

0

„Nie rozpoznaje” to mi ABSOLUTNIE NIC NIE MÓWI!

0

Taki błąd

0

Zajebisty błąd. Szkoda, że go w ogóle na tym zrzucie nie ma.

0

Nie wiem i nie chce mi się sprawdzać czy to się da tak rzutować poprawnie ale zupełnie wiem dlaczego
State := TOwnerDrawState(LongRec(itemState).Lo);
a nie:
State := TOwnerDrawState(itemState);

1

Nie możesz tak łatwo przekonwertować liczby typu Word na zbiór enumów, którym jest TOwnerDrawState.

Przy domyślnych ustawieniach, rozmiar zmiennej typu TOwnerDrawState to 4 bajty, a Ty masz liczbę dwubajtową. Sugeruję ją przepisać do zmiennej typu UInt32 i zadeklarować zmienną typu TOwnerDrawState, zabsolutowaną na tę liczbę. W ten sposób można się bezpośrednio dobrać do zawartości liczby, omijając niekompatybilność typów.

var
  RawState: UInt32;
  State: TOwnerDrawState absolute RawState;
begin
  RawState := LongRec(ItemState).Lo;

  // dalej używasz tylko zmiennej State

Możesz też usunąć absolute i po prostu przekopiować dane z liczby do zbioru za pomocą Move:

var
  RawState: UInt32;
  State: TOwnerDrawState;
begin
  RawState := LongRec(ItemState).Lo;
  Move(RawState, State, SizeOf(State));

Taki kod będzie się bez problemu kompilował i działał, ale sprawdź czy zbiór wyjściowy zawiera poprawne enumy. Problem tylko w tym, że jeśli rozmiar zbioru będzie inny niż 4 bajty (własne dyrektywy kompilatora), to oba powyższe kody przestaną działać prawidłowo. Dlatego pasuje się zastanowić nad tym, czy taka ”konwersja typów” jest w ogóle potrzebna.

Edit: zresztą, skoro wszystko jest zdefiniowane w młodszym słowie liczby 4-bajtowej, to nie ma sensu wyciągać z niej tego młodszego słowa — wystarczy całą liczbę zabsolutować na TOwnerDrawState i używać jej do odczytu enumów.

0

Nie podświetla :-(

procedure TL_ListBox.CNDrawItem(var Message: TWMDrawItem);
var
  //State: TOwnerDrawState;

  RawState: UInt32;
  State: TOwnerDrawState absolute RawState;
begin
   with Message.DrawItemStruct^ do
    begin
     RawState := LongRec(ItemState).Lo;
    //State := TOwnerDrawState(LongRec(itemState).Lo); // oryginal
    State := TOwnerDrawState(RawState);  //@{furious programming}
    State := TOwnerDrawState(itemState); //@kAzek

    FCanvas.Handle := hDC;
    FCanvas.Font := Font;
    FCanvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then
    begin
      FCanvas.Brush.Color := clHighlight;
      FCanvas.Font.Color := clHighlightText
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State) else
      FCanvas.FillRect(rcItem);
    if odFocused in State then DrawFocusRect(hDC, rcItem);
    FCanvas.Handle := 0;
  end;
end;             
0

Kiedy zrobię tak wywala błąd na itemState, itemID

L_ListBox.pas(1075,38) Error: Identifier not found "itemState"
L_ListBox.pas(1080,17) Error: Identifier not found "itemID"

procedure TL_ListBox.CNDrawItem(var Message: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
   //with Message.DrawItemStruct^  gdy wyłaczę
    begin

    State := TOwnerDrawState(LongRec(itemState).Lo); // oryginal

    FCanvas.Handle := hDC;
    FCanvas.Font := Font;
    FCanvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then
    begin
      FCanvas.Brush.Color := clHighlight;
      FCanvas.Font.Color := clHighlightText
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State) else
      FCanvas.FillRect(rcItem);
    if odFocused in State then DrawFocusRect(hDC, rcItem);
    FCanvas.Handle := 0;
  end;
end;          
0

Komponent działa i bez moich 4 dodatkowych pytań. Mogę stosować OnClick podwójne klikanie OnDblClick. Jednak to tak jakby wybierać na papierze bez widoku co się wybrało. Wiem i czuje, że się uda. Tylko pozostaje kwestia podświetlenia mouse wyboru. Komponent cały czas testuje na delphi 7 i lazarusie, aby zobaczyć czy w delphi coś jest dopisywanie w vcl. Jednak zachowuje się tak jak w lazarusie w wyświetlaniu. Jeszcze pozostaje kwestia podbijania pamięci. Kiedy dwa razy ładuję plik. pamięć wzrasta dwukrotnie. To jedyna różnica między delphi 7 a lazarusem. Tym zajmę się końcu.

0
State := TOwnerDrawState(RawState);  //@{furious programming}

Ja Ci nie kazałem czegoś takiego robić.

Napisz sobie funkcję, która przyjmie itemState w postaci liczby i zwróci zbiór TOwnerDrawState. Wtedy się okaże czy winne jest ”rzutowanie”, czy kod renderujący zawartość pozycji.

0

@furious programming: Idę dobrą drogą. Wpierw z`delphi na lazarusa Count było dla Ciebie read only . Jest teraz odblokowany. Pytałem Ciebie co oznacza read only Następnie @kAzek przedstawił, że musi być drawfixed. Tak pomogło. W kontrolce pojawiły się dane. Teraz chodzi tylko o mouse. Wszystko jest możliwe dla tego co wierzy... @furious programming: od samego początku nie wiem, albo nie chciał przyznać się do tego, że nic tym tokiem nie uzyskam. Wciąż sprowadza mnie na złe szukanie. Problem klas delphi na lazarusa gdy pytalem o Problem klas delphi na lazarusa była cisza. Także nie ma programistów geniuszy.

1
Mariusz Bruniewski napisał(a):

@furious programming: Idę dobrą drogą. Wpierw z`delphi na lazarusa Count było dla Ciebie read only .

Nie tylko było, ale i jest nadal — w LCL to jest i zawsze będzie właściwość tylko do odczytu. Przerobić ją na RW nie problem, co pokazałem w swoim kodzie. Dorobić do niej wirtualizację, bez potrzeby ładowania wszystkich danych do pamięci i żmudnego rzeźbienia w WinAPI to też nie problem — pisałem jak to zrobić.

Pytałem Ciebie co oznacza read only

Google/Translator szybciej udzieliłby odpowiedzi na to pytanie.

Wciąż sprowadza mnie na złe szukanie. Problem klas delphi na lazarusa gdy pytalem o Problem klas delphi na lazarusa była cisza. Także nie ma programistów geniuszy.

Problemem nie jest to, że Twój problem jest tak bardzo nietuzinkowy/wyszukany, a to, że ciągle upierasz się przy swoim, olewasz sugestie, przedstawiasz jakieś magiczne wytłumaczenia i ogólnie lejesz wodę potwornie, dlatego nikt (łącznie ze mną) nie ma ochoty udzielać się w Twoich wątkach.

0

Programowanie nie jest dla spekulacji, lecz dla kreacji. ROZUMIESZ TO,?

0

Programowanie jest dla ludzi myślących i rozumiejących, że komputer to zero-jedynkowa maszyna, i żadna wiara ani inne magiczne czynności nie zmuszą go do działania, jeśli kod jest nieprawidłowy. ROZUMIESZ TO?

0

Czy możecie spojrzeć okiem na ten kod. Uwzględniłem Wasze podpowiedzi, aby kod dał się skompilować.
Testowałem poprawki na delphi 7 i Lazarusie. W delphi 7 Wasze podpowiedzi działają.

unit L_LISTBOX;

 {$mode objfpc}{$H+}

interface

    uses Math, StdCtrls, Controls, Classes, Forms, Graphics, Messages, Windows, SysUtils, Commctrl, Types,
         LResources, LCLType, LCLIntf, LMessages;

    type
    TListBoxStyle = (lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtual, lbVirtualOwnerDraw);

    TLBGetDataEvent       = procedure(Control: TWinControl; Index: Integer; var Data: string) of object;
    TLBFindDataEvent      = function(Control : TWinControl; FindString: string): Integer of object;
    TLBGetDataObjectEvent = procedure(Control: TWinControl; Index: Integer; var DataObject: TObject) of object;

  TL_ListBox = class(TlistBox)
  private
    FMultiSelect : Boolean;
    FAutoComplete: Boolean;
    FCount: Integer;
    FItems: TStrings;
    FFilter: String;
    FLastTime: Cardinal;
    FBorderStyle: TBorderStyle;
    FCanvas: TCanvas;
    FColumns: Integer;
    FItemHeight: Integer;
    FOldCount: Integer;
    FStyle: TListBoxStyle;
    FIntegralHeight: Boolean;
    FSorted: Boolean;
    FExtendedSelect: Boolean;
    FTabWidth: Integer;
    FSaveItems: TStringList;
    FSaveTopIndex: Integer;
    FSaveItemIndex: Integer;
    FOnDrawItem: TDrawItemEvent;
    FOnMeasureItem: TMeasureItemEvent;
    FOnData: TLBGetDataEvent;
    FOnDataFind: TLBFindDataEvent;
    FOnDataObject: TLBGetDataObjectEvent;
    function GetItemHeight: Integer;
    function GetTopIndex: Integer;
    procedure LBGetText(var Message: TMessage); message LB_GETTEXT;
    procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN;
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetColumnWidth;
    procedure SetColumns(Value: Integer);
    procedure SetCount(const Value: Integer);
    procedure SetExtendedSelect(Value: Boolean);
    procedure SetIntegralHeight(Value: Boolean);
    procedure SetItemHeight(Value: Integer);
    procedure SetItems(Value: TStrings);
    procedure SetSelected(Index: Integer; Value: Boolean);
    procedure SetSorted(Value: Boolean);
    procedure SetStyle(Value: TListBoxStyle);
    procedure SetTabWidth(Value: Integer);
    procedure SetTopIndex(Value: Integer);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    function GetScrollWidth: Integer;
    procedure SetScrollWidth(const Value: Integer);
  protected
    FMoving: Boolean;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    function DoGetData(const Index: Integer): String;
    function DoGetDataObject(const Index: Integer): TObject;
    function DoFindData(const Data: String): Integer;
    procedure WndProc(var Message: TMessage); override;
    procedure DragCanceled; override;
    procedure DrawItem(Index: Integer; Rect: TRect;State: TOwnerDrawState); virtual;
    function GetCount: Integer; //override;
    function GetSelCount: Integer; //override;
    //procedure MeasureItem(Index: Integer; var Height: Integer); virtual;
    function InternalGetItemData(Index: Integer): Longint; dynamic;
    procedure InternalSetItemData(Index: Integer; AData: Longint); dynamic;
    function GetItemData(Index: Integer): LongInt; dynamic;
    function GetItemIndex: Integer; override;
    function GetSelected(Index: Integer): Boolean;
    procedure KeyPress(var Key: Char); override;
    procedure SetItemData(Index: Integer; AData: LongInt); dynamic;
    procedure ResetContent; dynamic;
    procedure DeleteString(Index: Integer); dynamic;
    procedure SetMultiSelect(Value: Boolean); override;
    procedure SetItemIndex(const Value: Integer); //override;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Columns: Integer read FColumns write SetColumns default 0;
    property ExtendedSelect: Boolean read FExtendedSelect write SetExtendedSelect default True;
    property IntegralHeight: Boolean read FIntegralHeight write SetIntegralHeight default False;
    property ItemHeight: Integer read GetItemHeight write SetItemHeight;
    property ParentColor default False;
    property Sorted: Boolean read FSorted write SetSorted default False;
    //property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;          // tu wyłaczyłem
    property TabWidth: Integer read FTabWidth write SetTabWidth default 0;
    property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;
    property OnMeasureItem: TMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;
    //property OnData: TLBGetDataEvent read FOnData write FOnData;                          // tu wyłaczyłem
    //property OnDataObject: TLBGetDataObjectEvent read FOnDataObject write FOnDataObject;  // tu wyłaczyłem
    //property OnDataFind: TLBFindDataEvent read FOnDataFind write FOnDataFind;
  public                                                                                    // tu wyłaczyłem
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddItem(Item: String; AObject: TObject); //override;
    procedure Clear; override;
    procedure ClearSelection; //override;
    //procedure CopySelection(Destination: TListBox); //override;
    procedure CopySelection;
    procedure DeleteSelected; override;
    function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
    function ItemRect(Index: Integer): TRect;
    procedure SelectAll; override;
    property AutoComplete: Boolean read FAutoComplete write FAutoComplete default True;
    property Canvas: TCanvas read FCanvas;
    property Count: Integer read GetCount write SetCount; 
    property Items: TStrings read FItems write SetItems;
    property Selected[Index: Integer]: Boolean read GetSelected write SetSelected;
    property ScrollWidth: Integer read GetScrollWidth write SetScrollWidth default 0;
    property TopIndex: Integer read GetTopIndex write SetTopIndex;
  published
    property TabStop default True;

    property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;         // tu dodałem
    property OnData: TLBGetDataEvent read FOnData write FOnData;                         // tu dodałem
    property OnDataObject: TLBGetDataObjectEvent read FOnDataObject write FOnDataObject; // tu dodałem
    property OnDataFind: TLBFindDataEvent read FOnDataFind write FOnDataFind;            // tu dodałem

  end;

  // Gdy zastosuję poniższą klasę to wpływa na zwykły ListBox
  
  {TListBox = class(TL_ListBox)
   private
  published
    property Style;
    property AutoComplete;
    property Align;
    property Anchors;
    //property BevelEdges;
    //property BevelInner;
    //property BevelKind default bkNone;
    //property BevelOuter;
    property BiDiMode;
    property BorderStyle;
    property Color;
    property Columns;
    property Constraints;
    //property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ExtendedSelect;
    property Font;
    //property ImeMode;
    //property ImeName;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    property MultiSelect;
    property ParentBiDiMode;
    property ParentColor;
    //property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ScrollWidth;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property TabWidth;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnData;
    property OnDataFind;
    property OnDataObject;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;}

  procedure Register;

  implementation

  uses RTLConsts;

  resourcestring
    SErrorSettingCount = 'Error setting %s.Count';
    SListBoxMustBeVirtual = 'Listbox (%s) style must be virtual in order to set Count';
    SListIndexError = 'List %s is invalid';

  procedure Register;
  begin

   RegisterComponents('ex',[TL_ListBox]);
  end;

  type

  TListBoxStrings = class(TStrings)
  private
    ListBox:  TL_ListBox;
  protected
    procedure Put(Index: Integer; const S: string); override;
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    function Add(const S: string): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Move(CurIndex, NewIndex: Integer); override;
  end;

const
  BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);

{ TListBoxStrings }

function TListBoxStrings.GetCount: Integer;
begin
  Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);
end;

function TListBoxStrings.Get(Index: Integer): string;
var
  Len: Integer;
begin
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
    Result := ListBox.DoGetData(Index)
  else
  begin
    Len := SendMessage(ListBox.Handle, LB_GETTEXTLEN, Index, 0);
    if Len = LB_ERR then Error(SListIndexError, Index);
    SetLength(Result, Len);
    if Len <> 0 then
    begin
      Len := SendMessage(ListBox.Handle, LB_GETTEXT, Index, Longint(PChar(Result)));
      SetLength(Result, Len);  // LB_GETTEXTLEN isn't guaranteed to be accurate
    end;
  end;
end;

function TListBoxStrings.GetObject(Index: Integer): TObject;
begin
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
    Result := ListBox.DoGetDataObject(Index)
  else
  begin
    //Result := TObject(ListBox.GetItemData(Index));
    //if Longint(Result) = LB_ERR then Error(SListIndexError, Index);
  end;
end;

procedure TListBoxStrings.Put(Index: Integer; const S: string);
var
  I: Integer;
  TempData: Longint;
begin
  I := ListBox.ItemIndex;
  TempData := ListBox.InternalGetItemData(Index);
  // Set the Item to 0 in case it is an object that gets freed during Delete
  ListBox.InternalSetItemData(Index, 0);
  Delete(Index);
  InsertObject(Index, S, nil);
  ListBox.InternalSetItemData(Index, TempData);
  ListBox.ItemIndex := I;
end;

procedure TListBoxStrings.PutObject(Index: Integer; AObject: TObject);
begin
  if (Index <> -1) and not (ListBox.Style in [lbVirtual, lbVirtualOwnerDraw]) then
    //ListBox.SetItemData(Index, LongInt(AObject));
end;

function TListBoxStrings.Add(const S: string): Integer;
begin
  Result := -1;
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then exit;
  Result := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, Longint(PChar(S)));
  if Result < 0 then raise EOutOfResources.Create(SInsertLineError);
end;

procedure TListBoxStrings.Insert(Index: Integer; const S: string);
begin
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then exit;
  if SendMessage(ListBox.Handle, LB_INSERTSTRING, Index,
    Longint(PChar(S))) < 0 then
    raise EOutOfResources.Create(SInsertLineError);
end;

procedure TListBoxStrings.Delete(Index: Integer);
begin
  ListBox.DeleteString(Index);
end;

procedure TListBoxStrings.Exchange(Index1, Index2: Integer);
var
  TempData: Longint;
  TempString: string;
begin
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then exit;
  BeginUpdate;
  try
    TempString := Strings[Index1];
    TempData := ListBox.InternalGetItemData(Index1);
    Strings[Index1] := Strings[Index2];
    ListBox.InternalSetItemData(Index1, ListBox.InternalGetItemData(Index2));
    Strings[Index2] := TempString;
    ListBox.InternalSetItemData(Index2, TempData);
    if ListBox.ItemIndex = Index1 then
      ListBox.ItemIndex := Index2
    else if ListBox.ItemIndex = Index2 then
      ListBox.ItemIndex := Index1;
  finally
    EndUpdate;
  end;
end;

procedure TListBoxStrings.Clear;
begin
  ListBox.ResetContent;
end;

procedure TListBoxStrings.SetUpdateState(Updating: Boolean);
begin
  SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  if not Updating then ListBox.Refresh;
end;

function TListBoxStrings.IndexOf(const S: string): Integer;
begin
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
    Result := ListBox.DoFindData(S)
  else
    Result := SendMessage(ListBox.Handle, LB_FINDSTRINGEXACT, -1, LongInt(PChar(S)));
end;

procedure TListBoxStrings.Move(CurIndex, NewIndex: Integer);
var
  TempData: Longint;
  TempString: string;
begin
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then exit;
  BeginUpdate;
  ListBox.FMoving := True;
  try
    if CurIndex <> NewIndex then
    begin
      TempString := Get(CurIndex);
      TempData := ListBox.InternalGetItemData(CurIndex);
      ListBox.InternalSetItemData(CurIndex, 0);
      Delete(CurIndex);
      Insert(NewIndex, TempString);
      ListBox.InternalSetItemData(NewIndex, TempData);
    end;
  finally
    ListBox.FMoving := False;
    EndUpdate;
  end;
end;

{ TL_ListBox }

constructor TL_ListBox.Create(AOwner: TComponent);
const
  ListBoxStyle = [csSetCaption, csDoubleClicks, csOpaque];
begin
  inherited Create(AOwner);
  if NewStyleControls then
    ControlStyle := ListBoxStyle else
    ControlStyle := ListBoxStyle + [csFramed];

  Fstyle := lbVirtual; 
  Width := 121;
  Height := 97;
  TabStop := True;
  ParentColor := False;
  FAutoComplete := True;
  FItems := TListBoxStrings.Create;
  TListBoxStrings(FItems).ListBox := Self;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  FItemHeight := 16;
  FBorderStyle := bsSingle;
  FExtendedSelect := True;
  FOldCount := -1;
end;

destructor TL_ListBox.Destroy;
begin
  inherited Destroy;
  FCanvas.Free;
  FItems.Free;
  FSaveItems.Free;
end;

procedure TL_ListBox.AddItem(Item: String; AObject: TObject);
var
  S: String;
begin
  SetString(S, PChar(Item), StrLen(PChar(Item)));
  Items.AddObject(S, AObject);
end;

function TL_ListBox.GetItemData(Index: Integer): LongInt;
begin
  Result := SendMessage(Handle, LB_GETITEMDATA, Index, 0);
end;

procedure TL_ListBox.SetItemData(Index: Integer; AData: LongInt);
begin
  SendMessage(Handle, LB_SETITEMDATA, Index, AData);
end;

function TL_ListBox.InternalGetItemData(Index: Integer): LongInt;
begin
  Result := GetItemData(Index);
end;

procedure TL_ListBox.InternalSetItemData(Index: Integer; AData: LongInt);
begin
  SetItemData(Index, AData);
end;

procedure TL_ListBox.DeleteString( Index: Integer );
begin
  SendMessage(Handle, LB_DELETESTRING, Index, 0);
end;

procedure TL_ListBox.ResetContent;
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then exit;
  SendMessage(Handle, LB_RESETCONTENT, 0, 0);
end;

procedure TL_ListBox.Clear;
begin
  FItems.Clear;
end;

procedure TL_ListBox.ClearSelection;
var
  I: Integer;
begin
  if MultiSelect then
    for I := 0 to Items.Count - 1 do
      Selected[I] := False
  else
    ItemIndex := -1;
end;

{procedure TL_ListBox.CopySelection(Destination: TListBox);
var
  I: Integer;
begin
  if MultiSelect then
  begin
    for I := 0 to Items.Count - 1 do
      if Selected[I] then
        Destination.AddItem(PChar(Items[I]), Items.Objects[I]);
  end
  else
    if ItemIndex <> -1 then
      Destination.AddItem(PChar(Items[ItemIndex]), Items.Objects[ItemIndex]);
end;}

procedure TL_ListBox.CopySelection;
var
  I: Integer;
begin
  if MultiSelect then
  begin
    for I := 0 to Items.Count - 1 do
      if Selected[I] then
        AddItem(PChar(Items[I]), Items.Objects[I]);
  end
  else
    if ItemIndex <> -1 then
      AddItem(PChar(Items[ItemIndex]), Items.Objects[ItemIndex]);
end;

procedure TL_ListBox.DeleteSelected;
var
  I: Integer;
begin
  if MultiSelect then
  begin
    for I := Items.Count - 1 downto 0 do
      if Selected[I] then
        Items.Delete(I);
  end
  else
    if ItemIndex <> -1 then
      Items.Delete(ItemIndex);
end;

procedure TL_ListBox.SetColumnWidth;
var
  ColWidth: Integer;
begin
  if (FColumns > 0) and (Width > 0) then
  begin
    ColWidth := Trunc(ClientWidth / FColumns);
    if ColWidth < 1 then ColWidth := 1;
    SendMessage(Handle, LB_SETCOLUMNWIDTH, ColWidth, 0);
  end;
end;

procedure TL_ListBox.SetColumns(Value: Integer);
begin
  if FColumns <> Value then
    if (FColumns = 0) or (Value = 0) then
    begin
      FColumns := Value;
      //RecreateWnd; delphi
      RecreateWnd(Self);
    end else
    begin
      FColumns := Value;
      if HandleAllocated then SetColumnWidth;
    end;
end;

function TL_ListBox.GetItemIndex: Integer;
begin
  if MultiSelect then
    Result := SendMessage(Handle, LB_GETCARETINDEX, 0, 0)
  else
    Result := SendMessage(Handle, LB_GETCURSEL, 0, 0);
end;

function TL_ListBox.GetCount: Integer;
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then
    Result := FCount
  else
    Result := Items.Count;
end;

function TL_ListBox.GetSelCount: Integer;
begin
  Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0);
end;

procedure TL_ListBox.SetItemIndex(const Value: Integer);
begin
  if GetItemIndex <> Value then
    if MultiSelect then SendMessage(Handle, LB_SETCARETINDEX, Value, 0)
    else SendMessage(Handle, LB_SETCURSEL, Value, 0);
end;

procedure TL_ListBox.SetExtendedSelect(Value: Boolean);
begin
  if Value <> FExtendedSelect then
  begin
    FExtendedSelect := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

procedure TL_ListBox.SetIntegralHeight(Value: Boolean);
begin
  if Value <> FIntegralHeight then
  begin
    FIntegralHeight := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
    RequestAlign;
  end;
end;

function TL_ListBox.GetItemHeight: Integer;
var
  R: TRect;
begin
  Result := FItemHeight;
  if HandleAllocated and (FStyle = lbStandard) then
  begin
    Perform(LB_GETITEMRECT, 0, Longint(@R));
    Result := R.Bottom - R.Top;
  end;
end;

procedure TL_ListBox.SetItemHeight(Value: Integer);
begin
  if (FItemHeight <> Value) and (Value > 0) then
  begin
    FItemHeight := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

procedure TL_ListBox.SetTabWidth(Value: Integer);
begin
  if Value < 0 then Value := 0;
  if FTabWidth <> Value then
  begin
    FTabWidth := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

procedure TL_ListBox.SetMultiSelect(Value: Boolean);
begin
  if FMultiSelect <> Value then
  begin
    FMultiSelect := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

function TL_ListBox.GetSelected(Index: Integer): Boolean;
var
  R: Longint;
begin
  R := SendMessage(Handle, LB_GETSEL, Index, 0);
  if R = LB_ERR then
    raise EListError.CreateResFmt(@SListIndexError, [Index]);
  Result := LongBool(R);
end;

procedure TL_ListBox.SetSelected(Index: Integer; Value: Boolean);
begin
  if FMultiSelect then
  begin
    if SendMessage(Handle, LB_SETSEL, Longint(Value), Index) = LB_ERR then
      raise EListError.CreateResFmt(@SListIndexError, [Index]);
  end
  else
    if Value then
    begin
      if SendMessage(Handle, LB_SETCURSEL, Index, 0) = LB_ERR then
        raise EListError.CreateResFmt(@SListIndexError, [Index])
    end
    else
      SendMessage(Handle, LB_SETCURSEL, -1, 0);
end;

procedure TL_ListBox.SetSorted(Value: Boolean);
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then exit;
  if FSorted <> Value then
  begin
    FSorted := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

procedure TL_ListBox.SetStyle(Value: TListBoxStyle);
begin
  if FStyle <> Value then
  begin
    if Value in [lbVirtual, lbVirtualOwnerDraw] then
    begin
      Items.Clear;
      Sorted := False;
    end;
    FStyle := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

function TL_ListBox.GetTopIndex: Integer;
begin
  Result := SendMessage(Handle, LB_GETTOPINDEX, 0, 0);
end;

procedure TL_ListBox.LBGetText(var Message: TMessage);
var
  S: string;
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then
  begin
    if Assigned(FOnData) and (Message.WParam > -1) and (Message.WParam < Count) then
    begin
      S := '';
      OnData(Self, Message.wParam, S);
      StrCopy(PChar(Message.lParam), PChar(S));
      Message.Result := Length(S);
    end
    else
      Message.Result := LB_ERR;
  end
  else
    inherited;
end;

procedure TL_ListBox.LBGetTextLen(var Message: TMessage);
var
  S: string;
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then
  begin
    if Assigned(FOnData) and (Message.WParam > -1) and (Message.WParam < Count) then
    begin
      S := '';
      OnData(Self, Message.wParam, S);
      Message.Result := Length(S);
    end
    else
      Message.Result := LB_ERR;
  end
  else
    inherited;
end;

procedure TL_ListBox.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    //RecreateWnd; delphi
    RecreateWnd(Self);
  end;
end;

procedure TL_ListBox.SetTopIndex(Value: Integer);
begin
  if GetTopIndex <> Value then
    SendMessage(Handle, LB_SETTOPINDEX, Value, 0);
end;

procedure TL_ListBox.SetItems(Value: TStrings);
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then
    case Style of
      lbVirtual: Style := lbStandard;
      lbVirtualOwnerDraw: Style := lbOwnerDrawFixed;
    end;
  Items.Assign(Value);
end;

function TL_ListBox.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
//var
//Count: Integer;
//ItemRect: TRect;  // w delphi 7 zmienne: Count i ItemRect dają sie skompilować w lazarusie nie
begin
  if PtInRect(ClientRect, Pos) then
  begin
    Result := TopIndex;
    Count := Items.Count;
    while Result < Count do
    begin
      Perform(LB_GETITEMRECT, Result, Longint(@ItemRect));
      //if PtInRect(ItemRect, Pos) then Exit;
      Inc(Result);
    end;
    if not Existing then Exit;
  end;
  Result := -1;
end;

function TL_ListBox.ItemRect(Index: Integer): TRect;
//var
// Count: Integer; w delphi 7 zmienne: Count dają sie skompilować w lazarusie nie
begin
  Count := Items.Count;
  if (Index = 0) or (Index < Count) then
    Perform(LB_GETITEMRECT, Index, Longint(@Result))
  else if Index = Count then
  begin
    Perform(LB_GETITEMRECT, Index - 1, Longint(@Result));
    OffsetRect(Result, 0, Result.Bottom - Result.Top);
  end else FillChar(Result, SizeOf(Result), 0);
end;

procedure TL_ListBox.CreateParams(var Params: TCreateParams);
type
  PSelects = ^TSelects;
  TSelects = array[Boolean] of DWORD;
const
  Styles: array[TListBoxStyle] of DWORD =
    (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_OWNERDRAWFIXED,
     LBS_OWNERDRAWFIXED);
  Sorteds: array[Boolean] of DWORD = (0, LBS_SORT);
  MultiSelects: array[Boolean] of DWORD = (0, LBS_MULTIPLESEL);
  ExtendSelects: array[Boolean] of DWORD = (0, LBS_EXTENDEDSEL);
  IntegralHeights: array[Boolean] of DWORD = (LBS_NOINTEGRALHEIGHT, 0);
  MultiColumns: array[Boolean] of DWORD = (0, LBS_MULTICOLUMN);
  TabStops: array[Boolean] of DWORD = (0, LBS_USETABSTOPS);
  CSHREDRAW: array[Boolean] of DWORD = (CS_HREDRAW, 0);
  Data: array[Boolean] of DWORD = (LBS_HASSTRINGS, LBS_NODATA);
var
  Selects: PSelects;
begin
  inherited CreateParams(Params);

  Params.Style:= Params.Style and (not LBS_HASSTRINGS) or LBS_NODATA or LBS_OWNERDRAWFIXED;  // tu dodałem Twoją sugestię
  CreateSubClass(Params, 'LISTBOX');
  with Params do
  begin
    Selects := @MultiSelects;
    if FExtendedSelect then Selects := @ExtendSelects;
    Style := Style or (WS_HSCROLL or WS_VSCROLL or
      Data[Self.Style in [lbVirtual, lbVirtualOwnerDraw]] or
      LBS_NOTIFY) or Styles[FStyle] or Sorteds[FSorted] or
      Selects^[FMultiSelect] or IntegralHeights[FIntegralHeight] or
      MultiColumns[FColumns <> 0] or BorderStyles[FBorderStyle] or
      TabStops[FTabWidth <> 0];
    if NewStyleControls {and Ctl3D} and (FBorderStyle = bsSingle) then
    begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;
    WindowClass.style := WindowClass.style and not (CSHREDRAW[UseRightToLeftAlignment] or CS_VREDRAW);
  end;
end;

{procedure TL_ListBox.CreateParams(var Params: TCreateParams);
  begin
    inherited CreateParams(Params);
    Params.Style:= Params.Style and (not LBS_HASSTRINGS) or LBS_NODATA or LBS_OWNERDRAWFIXED;  
    CreateSubClass(Params, 'ListBox'); //to nie wiem po co masz skoro ta procedura w źródłach jest pusta (nie ma w ogóle kodu)!
end;}
       
procedure TL_ListBox.CreateWnd;
var
  W, H: Integer;
begin
  W := Width;
  H := Height;
  inherited CreateWnd;
  SetWindowPos(Handle, 0, Left, Top, W, H, SWP_NOZORDER or SWP_NOACTIVATE);
  if FTabWidth <> 0 then
    SendMessage(Handle, LB_SETTABSTOPS, 1, Longint(@FTabWidth));
  SetColumnWidth;
  if (FOldCount <> -1) or Assigned(FSaveItems) then
  begin
    if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
      Count := FOldCount;
    if FSaveItems <> nil then
    begin
      FItems.Assign(FSaveItems);
      FreeAndNil(FSaveItems);
    end;
    SetTopIndex(FSaveTopIndex);
    SetItemIndex(FSaveItemIndex);
    FOldCount := -1;
  end;
end;

procedure TL_ListBox.DestroyWnd;
begin
  if (FItems.Count > 0) then
  begin
    if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
      FOldCount := FItems.Count
    else
    begin
      FSaveItems := TStringList.Create;
      FSaveItems.Assign(FItems);
    end;
    FSaveTopIndex := GetTopIndex;
    FSaveItemIndex := GetItemIndex;
  end;
  inherited DestroyWnd;
end;

procedure TL_ListBox.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 TL_ListBox.WMLButtonDown(var Message: TWMLButtonDown);
var
  ItemNo : Integer;
  ShiftState: TShiftState;
begin
  ShiftState := KeysToShiftState(Message.Keys);
  if (DragMode = dmAutomatic) and FMultiSelect then
  begin
    if not (ssShift in ShiftState) or (ssCtrl in ShiftState) then
    begin
      ItemNo := ItemAtPos(SmallPointToPoint(Message.Pos), True);
      if (ItemNo >= 0) and (Selected[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);
end;

procedure TL_ListBox.CNCommand(var Message: TWMCommand);
begin
  case Message.NotifyCode of
    LBN_SELCHANGE:
      begin
        inherited Changed;
        Click;
      end;
    LBN_DBLCLK: DblClick;
  end;
end;

procedure TL_ListBox.WMPaint(var Message: TWMPaint);

  procedure PaintListBox;
  var
    DrawItemMsg: TWMDrawItem;
    MeasureItemMsg: TWMMeasureItem;
    DrawItemStruct: TDrawItemStruct;
    MeasureItemStruct: TMeasureItemStruct;
    //R: TRect; // delphi
    R: lpRect; // lazarus
    Y, I, H, W: Integer;
  begin
    { Initialize drawing records }
    DrawItemMsg.Msg := CN_DRAWITEM;
    DrawItemMsg.DrawItemStruct := @DrawItemStruct;
    DrawItemMsg.Ctl := Handle;
    DrawItemStruct.CtlType := ODT_LISTBOX;
    DrawItemStruct.itemAction := ODA_DRAWENTIRE;
    DrawItemStruct.itemState := 0;
    DrawItemStruct._hDC := Message.DC;  // zamiana hDC na _hDC
    DrawItemStruct.CtlID := Handle;
    DrawItemStruct.hwndItem := Handle;

    { Intialize measure records }
    MeasureItemMsg.Msg := CN_MEASUREITEM;
    MeasureItemMsg.IDCtl := Handle;
    MeasureItemMsg.MeasureItemStruct := @MeasureItemStruct;
    MeasureItemStruct.CtlType := ODT_ListBox;
    MeasureItemStruct.CtlID := Handle;

    { Draw the listbox }
    Y := 0;
    I := TopIndex;
    GetClipBox(Message.DC, R);
    H := Height;
    W := Width;
    while Y < H do
    begin
      MeasureItemStruct.itemID := I;
      if I < Items.Count then
        MeasureItemStruct.itemData := Longint(Pointer(Items.Objects[I]));
      MeasureItemStruct.itemWidth := W;
      MeasureItemStruct.itemHeight := FItemHeight;
      DrawItemStruct.itemData := MeasureItemStruct.itemData;
      DrawItemStruct.itemID := I;
      Dispatch(MeasureItemMsg);
      DrawItemStruct.rcItem := Rect(0, Y, MeasureItemStruct.itemWidth,
        Y + Integer(MeasureItemStruct.itemHeight));
      Dispatch(DrawItemMsg);
      Inc(Y, MeasureItemStruct.itemHeight);
      Inc(I);
      if I >= Items.Count then break;
    end;
  end;

begin
  if Message.DC <> 0 then
    { Listboxes don't allow paint "sub-classing" like the other windows controls
      so we have to do it ourselves. }
    PaintListBox
  else inherited;
end;

procedure TL_ListBox.WMSize(var Message: TWMSize);
begin
  inherited;
  SetColumnWidth;
end;

procedure TL_ListBox.DragCanceled;
var
  M: TWMMouse;
  MousePos: TPoint;
begin
  with M do
  begin
    Msg := WM_LBUTTONDOWN;
    GetCursorPos(MousePos);
    Pos := PointToSmallPoint(ScreenToClient(MousePos));
    Keys := 0;
    Result := 0;
  end;
  DefaultHandler(M);
  M.Msg := WM_LBUTTONUP;
  DefaultHandler(M);
end;

procedure TL_ListBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Flags: Longint;
  Data: String;
begin
  if Assigned(FOnDrawItem) then FOnDrawItem(Self, Index, Rect, State) else
  begin
    FCanvas.FillRect(Rect);
    if Index < Count then
    begin
       {bez DrawTextBiDiModeFlags działa i w delphi}
       Flags := DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX;

      //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;

{procedure TL_ListBox.MeasureItem(Index: Integer; var Height: Integer);
begin
  if Assigned(FOnMeasureItem) then FOnMeasureItem(Self, Index, Height)
end;}

procedure TL_ListBox.CNDrawItem(var Message: TWMDrawItem);
var
  //State: TOwnerDrawState;
  RawState: Uint; // w delphi 7 kompiluje się Uint nie UInt32;
  State: TOwnerDrawState absolute RawState;
begin
  with Message.DrawItemStruct^ do
  begin
     RawState := LongRec(ItemState).Lo; // w delphi 7 działa poprawnie w lazarusie nie

    //State := TOwnerDrawState(LongRec(itemState).Lo); delphi
    FCanvas.Handle := hDC;
    FCanvas.Font := Font;
    FCanvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then
    begin
      FCanvas.Brush.Color := clHighlight;
      FCanvas.Font.Color := clHighlightText
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State) else
      FCanvas.FillRect(rcItem);
    if odFocused in State then DrawFocusRect(hDC, rcItem);
    FCanvas.Handle := 0;
  end;
end;

procedure TL_ListBox.CNMeasureItem(var Message: TWMMeasureItem);
begin
  with Message.MeasureItemStruct^ do
  begin
    itemHeight := FItemHeight;
    if FStyle = lbOwnerDrawVariable then
      MeasureItem(itemID, Integer(itemHeight));
  end;
end;

procedure TL_ListBox.CMCtl3DChanged(var Message: TMessage);
begin
  //if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd; delphi
  if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd(Self);
  inherited;
end;

procedure TL_ListBox.SelectAll;
var
  I: Integer;
begin
  if FMultiSelect then
    for I := 0 to Items.Count - 1 do
      Selected[I] := True;
end;

procedure TL_ListBox.KeyPress(var Key: Char);

  procedure FindString;
  var
    Idx: Integer;
  begin
    if Style in [lbVirtual, lbVirtualOwnerDraw] then
      Idx := DoFindData(FFilter)
    else
      Idx := SendMessage(Handle, LB_FINDSTRING, -1, LongInt(PChar(FFilter)));
    if Idx <> LB_ERR then
    begin
      if MultiSelect then
      begin
        ClearSelection;
        SendMessage(Handle, LB_SELITEMRANGE, 1, MakeLParam(Idx, Idx))
      end;
      ItemIndex := Idx;
      Click;
    end;
    if not (Ord(Key) in [VK_RETURN, VK_BACK, VK_ESCAPE]) then
      Key := #0;  // Clear so that the listbox's default search mechanism is disabled
  end;

var
  Msg: TMsg;
begin
  inherited KeyPress(Key);
  if not FAutoComplete then exit;
  if GetTickCount - FLastTime >= 500 then
    FFilter := '';
  FLastTime := GetTickCount;

  if Ord(Key) <> VK_BACK then
  begin
    if Key in LeadBytes then
    begin
      if PeekMessage(Msg, Handle, WM_CHAR, WM_CHAR, PM_REMOVE) then
      begin
        FFilter := FFilter + Key + Chr(Msg.wParam);
        Key := #0;
      end;
    end
    else
      FFilter := FFilter + Key;
  end
  else
  begin
    while ByteType(FFilter, Length(FFilter)) = mbTrailByte do
      Delete(FFilter, Length(FFilter), 1);
    Delete(FFilter, Length(FFilter), 1);
  end;

  if Length(FFilter) > 0 then
    FindString
  else
  begin
    ItemIndex := 0;
    Click;
  end;
end;

procedure TL_ListBox.SetCount(const Value: Integer);
var
  Error: Integer;
begin   
  if Style in [lbVirtual, lbVirtualOwnerDraw] then
  begin
    // Limited to 32767 on Win95/98 as per Win32 SDK
    Error := SendMessage(Handle, LB_SETCOUNT, Value, 0);
    if (Error <> LB_ERR) and (Error <> LB_ERRSPACE) then
      FCount := Value
    else
      raise Exception.CreateFmt(SErrorSettingCount, [Name]);
  end
  else
    raise Exception.CreateFmt(SListBoxMustBeVirtual, [Name]);
end;

function TL_ListBox.DoGetData(const Index: Integer): String;
begin
  if Assigned(FOnData) then FOnData(Self, Index, Result);
end;

function TL_ListBox.DoGetDataObject(const Index: Integer): TObject;
begin
  if Assigned(FOnDataObject) then FOnDataObject(Self, Index, Result);
end;

function TL_ListBox.DoFindData(const Data: String): Integer;
begin
  if Assigned(FOnDataFind) then
    Result := FOnDataFind(Self, Data)
  else
    Result := -1;
end;

function TL_ListBox.GetScrollWidth: Integer;
begin
  Result := SendMessage(Handle, LB_GETHORIZONTALEXTENT, 0, 0);
end;

procedure TL_ListBox.SetScrollWidth(const Value: Integer);
begin
  if Value <> ScrollWidth then
    SendMessage(Handle, LB_SETHORIZONTALEXTENT, Value, 0);
end;

end.
0

To jest zupełnie nieprawidłowo zrobione:

TL_ListBox = class(TlistBox)
private
    FMultiSelect : Boolean;
    FAutoComplete: Boolean;
    FCount: Integer;
    FItems: TStrings;
    FFilter: String;
    FLastTime: Cardinal;
    FBorderStyle: TBorderStyle;
    FCanvas: TCanvas;
...

przecież to wszystko jest już TCustomListBox, więc tu jest to powielane!

tak należy to zrobić:

TL_ListBox = class(TWinControl)
...

o ile miałoby to sens, bo ja nie widzę potrzeby przepisywania kodu ListBox z delphi.

0

@kwalifika jeśli utworzę TL_ListBox = class(TWinControl), TL_ListBox = class(TCustomListBox) TL_ListBox = class(TCustomListControl), gdzie dla lazarusa nie jest rozpoznawana ta ostatnia klasa, otrzymam czary mary. Myślę, że tutaj jest problem w State := TOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo); lub w jego PaintBox . Kod ma się kompilować oraz działać, a nie wszystko zmieniać i nie znać odpowiedzi.

0

State?
Tworzysz fikcyjne problemy...

pierwsze z brzegu możliwe rozwiązania:

  1. możesz się męczyć i zrobić swoją klasę od zera: SuperList + no data..
  2. użyć innej - alternatywne, już gotowej klasy: sprawdź to - DrawGrid, ListView, itp.
0

spróbuj w tym kodzie zmienić nazwy zmiennych:

function TL_ListBox.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
//var
//Count: Integer;
//ItemRect: TRect;  // w delphi 7 zmienne: Count i ItemRect dają sie skompilować w lazarusie nie
begin
  if PtInRect(ClientRect, Pos) then
  begin
    Result := TopIndex;
    Count := Items.Count;

np. cnt zamiast Count, oraz ItemRc zamiast ItemRect.
podobnie niżej.

Ponadto : Items.Count ma chyba zawsze 0 dla virtual, zatem tu należy użyć: Count lub GetCount.

0

@kwalifika: Wspominałaś, że do tego należy użyć miej kodu. Jeśli użyje TWinControl i tak każde zdarzenie kotrolki będę musiał napisać w kodzie od nowa. Stąd klasa TListBox. Ten komponent działa L_Listbox w lazarusie. Ma jednak dwie wady. ItemHeight jeśli mam czcionkę np size 10 to ItemHeight musi być 16 jeśli zmienię czcionkę jej wielkość muszę w komponencie zmieniać i dodawać 6 do ItemHeight. Komponent działa bardzo szybko jak w delphi. To zaleta. Rozwiązaniem zwalnianie pamięci podczas zamykania formy. JEST tylko jeden problem w kontrolce nie mogę podswietlic danego itema. Suwak działa poprawnie. To przypomina gdybym na listę nałożył readonly = true. Do tej pory umieszczalem kod kontrolki i przykład wywołania. Myślę, że problem polega na rysowaniu takiego niebieskiego pola podczas zaznaczania :-)

0

@kwalifika: troche pokory co do geniuszy tutaj na forum. Daj screena wyświetlający kombinacje Lotto dawniej Duży lotek, że Twoja kontrolka w lazarusie wybierze items?

4

Od kilku dni czytam te wątki i nie mogę uwierzyć. @wloochacz próbuje podpowiedzieć, ale lekko się przekomarza. Sądzę, że trzeba powiedzieć jak krowie na rowie. Skoro na ekranie masz maksymalnie do kilkuset rekordów (przy 8k wejdzie maksymalnie ok 200 na wysokość), to nie musisz więcej wczytywać. Masz suwak - racja, ale to robisz tak, że jak dochodzisz do końca wczytanej dziedziny to dynamicznie doczytujesz resztę danych, a stare już nie widoczne zwalniasz. Żeby było to płynne możesz zrobić sobie bufor np. 100 rekordów, jak dojdziesz do połowy bufora to zaczynasz do niego doczytywać resztę danych a stare usuwasz.

Taka architektura/podejście niesie za sobą parę rzeczy.

1 Szybciej wczytać kilka KB danych niż kilka GB.
2 Program zajmuje mniej ramu.

Przy obecnej prędkości dysków, oraz przez sposób użycia - wizualne przeglądanie danych - jest to najlepszy sposób, a poprawnie wykonane wczytywanie będzie niezauważalne. Jeśli chciałbym operować na tych danych to może warto by zrobić cache w pamięci. Ale należało by do tego zrobić stosowną warstwę w aplikacji, a nie chamsko ładować do kontrolki wizualnej! To tzw. wczytywanie leniwe - wczytujemy dopiero wtedy jak potrzebujemy daną daną - czyli jak chcemy ją wyświetlić. Jak jest niewidoczna w kontrolce to jej nie potrzebujemy w pamięci.

Generalnie powinna być warstwa danych co to wczytuje właśnie do buforów, warstwa logiki, która operuje na danych i warstwa prezentacyjna, która prezentuje w kontrolkach te dane. Wtedy reszta aplikacji jest niezależna od warstwy dostarczania danych wtedy może to być klasa czytająca dane z pliki, komunikująca się po TCP z jakąś bazą lub po HTTP z jakimś REST API, czy właśnie trzymająca wszystko w pamięci.

Wybacz, ale trzymanie milionów rekordów w pamięci kontrolki, jeśli nie liczymy właśnie jakiś kostek olap etc. jest moim zdaniem kardynalnym błędem lub próbą trollowania.

0

Czy jest możliwość taka, jeśli w lazarusie canvas jest read-only dla L_ListBox1.Canvas stad nie mogę podświetlić niebieskiego pola. Spróbuje go odblokować jak Count.

1

Nie ma takiej możliwości, bo Canvas nigdy nie jest read-only. Żeby nie dało się po nim malować, trzeba by go celowo zablokować metodą Lock/LockCanvas lub jakimiś windowsowymi funkcjami. Nie możesz podświetlić itema, bo albo w stylach tego itema nie ma informacji o podświetleniu, albo źle tę informację pozyskujesz. No ale takie są skutki dłubania w WinAPI w połączeniu z kontrolkami, których zachowanie opiera się o widgetsety.

0

https://4programmers.net/Forum/Delphi_Pascal/167892-Delphi_
Limit w lbVirtual przekracza ponad 2 miliardy linii. Później kontrolka nie wyświetla już nić.

1

Canvas mam w public property Canvas: TCanvas read FCanvas; być może muszę podbić to do published

Nie rozumiesz co ten zapis oznacza. A oznacza tyle, że referencja jest tylko do odczytu. Czyli bez problemu można korzystać ze wszystkich metod i właściwości tego obiektu (a nawet go zwolnić, choć to bez sensu), ale nie można do niej niczego przypisać. Natomiast to co widoczne jest w kontrolce na ekranie, nie ma nic wspólnego z deklaracją właściwości płótna tejże kontrolki.

Deklaracja właściwości w sekcji published służy tylko do tego, aby można ją było znaleźć za pomocą RTTI, czyli np. do jej pokazania w oknie Inspektora Obiektów. Choć enumeracja właściwości może służyć do wielu celów, nie tylko na potrzeby okienka IO.

Mariusz Bruniewski napisał(a):

https://4programmers.net/Forum/Delphi_Pascal/167892-Delphi_

Limit w lbVirtual przekracza ponad 2 miliardy linii. Później kontrolka nie wyświetla już nić.

Pewnie integer overflow — dla 32-bitowej liczby ze znakiem, zakres wartości to -2147483648 .. 2147483647.

0

Pewnie uda mi się to. Tylko muszę być cierpliwy... :-) i odporny na Wasze komentarze ...

0

A mnie nie — jest różnica w deklaracjach typów (nie wiadomo dlaczego, ale jest) i obecnym rozwiązaniem tego problemu jest zadeklarowanie modułu StdCtrls wcześniej niż Windows, aby kompilator skorzystał z tego poprawnego typu danych.

Jak chcesz mieć pewność, że poprawne flagi zostają sprawdzone, to napisz sobie funkcję, która za pomocą operacji logicznych (nie rzutowania) wyciągnie informacje z danych dostarczonych przez komunikat, uzupełni zbiór enumów i go zwróci.

Chodzi mi o taką funkcję (składnia dla Free Pascala):

function ItemStateToOwnerDrawState(const AState: Word): TOwnerDrawState;
begin
  Result := [];

  if AState and ODS_CHECKED      <> 0 then Result += [odChecked];
  if AState and ODS_COMBOBOXEDIT <> 0 then Result += [odComboBoxEdit];
  if AState and ODS_DEFAULT      <> 0 then Result += [odDefault];
  if AState and ODS_DISABLED     <> 0 then Result += [odDisabled];
  if AState and ODS_FOCUS        <> 0 then Result += [odFocused];
  if AState and ODS_GRAYED       <> 0 then Result += [odGrayed];
  if AState and ODS_HOTLIGHT     <> 0 then Result += [odHotLight];
  if AState and ODS_INACTIVE     <> 0 then Result += [odInactive];
  if AState and ODS_NOACCEL      <> 0 then Result += [odNoAccel];
  if AState and ODS_NOFOCUSRECT  <> 0 then Result += [odNoFocusRect];
  if AState and ODS_SELECTED     <> 0 then Result += [odSelected];
end;

Dzięki temu będziesz mógł skorzystać z dowolnego typu TOwnerDrawState, bez obawy, że coś zostanie źle zrzutowane.

0

@furious programming obecnym rozwiązaniem tego problemu jest zadeklarowanie modułu StdCtrls wcześniej niż Windows. @Mariusz Bruniewski - nie rozumie tego chodzi o główne uses a w nim poniższe uses. Czy w przeszeregowaniu. Bo jeśli zacznę zmieniać i przypisywać z górnego uses LCLType lub StdCtrls do uses poniżej funkcje i procedury nie będą działały w private. O to chodzi? uses Math, StdCtrls, Controls, Classes, Forms, Graphics, Messages, Windows, SysUtils, Commctrl, Types, LResources, LCLType, LCLIntf, LMessages;

1 użytkowników online, w tym zalogowanych: 0, gości: 1