AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Zurück Delphi-PRAXiS Programmierung allgemein GUI-Design mit VCL / FireMonkey / Common Controls VST 0tes Item / Node löschen führt nicht zum gewünschten Ergebnis [Fehler gefunden]
Thema durchsuchen
Ansicht
Themen-Optionen

VST 0tes Item / Node löschen führt nicht zum gewünschten Ergebnis [Fehler gefunden]

Ein Thema von DieDolly · begonnen am 18. Mai 2019
Antwort Antwort
DieDolly

Registriert seit: 22. Jun 2018
2.175 Beiträge
 
#1

VST 0tes Item / Node löschen führt nicht zum gewünschten Ergebnis [Fehler gefunden]

  Alt 18. Mai 2019, 23:01
Ich baue auf einem Code aus dem Forum auf. Der Code ist zu 99% von hier. Was ich hinzugefügt habe ist das Löschen eines Eintrags in der FMyDataClasses Liste.
Sobald ich den Eintrag 0 löschen möchte, gehen im VST scheinbar alle Daten verloren. Eintrag 1 kann ich löschen.
Child Items werden scheinbar auch nicht gelöscht. Also ganz komisch irgendwie.

Fehler gefunden! Vor dem List Delete() muss vst1.Clear; aufgerufen werden.

Wenn man das 0te Item nicht so löschen kann, wie dann?

Delphi-Quellcode:
unit Unit1;

interface

uses
 Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
 Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Generics.Collections, VirtualTrees, Vcl.StdCtrls;

type
 TMyDataClass = class(TObject)
  ID: Integer;
  Name: string;
  HasChildren: Boolean;
  NodeColor: TColor;
 end;

 PMyDataClass = ^TMyDataClass;
 TMyDataClasses = TObjectList<TMyDataClass>;

 TForm1 = class(TForm)
  vst1: TVirtualStringTree;
  btnCreate1MioObjects: TButton;
  btnCreate100TObjects: TButton;
  lblObjectDuration: TLabel;
  lblNodeDuration: TLabel;
  Button1: TButton;
  procedure FormCreate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
  procedure vst1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
  procedure vst1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
  procedure vst1InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal);
  procedure vst1PaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType);
  procedure btnCreate100TObjectsClick(Sender: TObject);
  procedure btnCreate1MioObjectsClick(Sender: TObject);
  procedure Button1Click(Sender: TObject);
 private
  {Private-Deklarationen}
  FMyDataClasses: TMyDataClasses;
  procedure CreateSomeObjects(const ACount: Integer);
 public
  {Public-Deklarationen}
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnCreate1MioObjectsClick(Sender: TObject);
begin
 CreateSomeObjects(1000000);
end;

procedure TForm1.btnCreate100TObjectsClick(Sender: TObject);
begin
 CreateSomeObjects(2);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 FMyDataClasses.Delete(0); // LÖSCHE DEN ERSTEN EINTRAG - SCHLÄGT FEHL
 vst1.RootNodeCount := FMyDataClasses.Count;
end;

procedure TForm1.CreateSomeObjects(const ACount: Integer);
var
 i: Integer;
 Data: TMyDataClass;
 Start: Cardinal;
begin
 Start := GetTickCount;
 vst1.Clear;
 FMyDataClasses.Clear;
 for i := 0 to ACount - 1 do
  begin
   Data := TMyDataClass.Create;
   Data.ID := i + 1;
   Data.Name := 'DataObject ' + IntToStr(i + 1);
   Data.HasChildren := True;
   Data.NodeColor := Random($FFFFFF);

   FMyDataClasses.Add(Data); // Hier die erzeugten Objekte zwischenspeichern
  end;
 lblObjectDuration.Caption := 'Dauer Object Erstellung: ' + IntToStr(GetTickCount - Start) + 'ms';

 Start := GetTickCount;
 vst1.RootNodeCount := ACount;
 lblNodeDuration.Caption := 'Dauer Node Erstellung: ' + IntToStr(GetTickCount - Start) + 'ms';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Randomize;
 FMyDataClasses := TMyDataClasses.Create(True); // Owns Objects auf true, damit beim Freigeben der Liste auch die darin enthaltenen Objekte automatisch freigegeben werden
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 FMyDataClasses.Free;
end;

procedure TForm1.vst1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
 NodeData: TMyDataClass;
begin
 if (vst1.GetNodeLevel(Node) = 0) then
  begin
   NodeData := Node.GetData<TMyDataClass>;

   CellText := NodeData.Name;
  end
 else
  CellText := 'SubItem ' + IntToStr(Node^.Index + 1);
end;

procedure TForm1.vst1InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal);
begin
 ChildCount := 2;
end;

procedure TForm1.vst1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
var
 NodeData: TMyDataClass;
begin
 Node.SetData<TMyDataClass>(FMyDataClasses[Node.Index]);
 NodeData := Node.GetData<TMyDataClass>;

 if (vst1.GetNodeLevel(Node) = 0) then
  begin // Nur auf dem ersten NodeLevel Children zulassen
   if (NodeData.HasChildren) then
    begin
     Include(InitialStates, ivsHasChildren); // Hier wird im Status der Node vermerkt, dass die Node mindestens 1 ChildNode hat und das + Symbol angezeigt werden soll
    end;
  end;
end;

procedure TForm1.vst1PaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType);
var
 NodeData: TMyDataClass;
begin
 NodeData := Node.GetData<TMyDataClass>;

 if (vst1.GetNodeLevel(Node) = 0) then
  begin
   TargetCanvas.Font.Color := NodeData.NodeColor;
  end;
end;

end.

Geändert von DieDolly (18. Mai 2019 um 23:15 Uhr)
  Mit Zitat antworten Zitat
Antwort Antwort


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 05:19 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz