VirtualDrawTree

vložil Radek Červinka 8. března 2011 23:20

Už jsem několikrát naznačil, že Virtual TreeView považuji za nejlepší open source komponentu (a pravděpodobně i komponentu vůbec) pro Delphi.

Dnes jsem potřeboval udělat specifické řešení: rozklikávací položky, na které se dá kreslit, a které mají variabilní výšku. A napadlo mne použít TVirtualDrawTree.

Pro úplnost: první verze používala TDrawGrid, ale tam je problém s posuvníkem, jelikož je podporován jen posun po buňkách.

Komponenty Virtual TreeView jsou v podstatě dvě komponenty, obě jsou ale následníkem TBaseVirtualTree. Zatím jsem zde popisoval TVirtualStringTree (viz dole tag) - obsahuje podporu pro vykreslování textů - na rozdíl od TVirtualDrawTree, kde musíte kreslit všechno (tedy kromě ikon a čar pro uzel). Ukáži jednoduchý program, který ve stromě v první úrovni vypisuje text a ve druhé úrovni kreslí data, ale které jsou různě vysoké.

TVirtualDrawTree

Pro jistotu: každý geometrický útvar je různě vysoký, přičemž focus se přizpůsobuje výšce řádku. Všechny geometrické útvary jsou kresleny na TCanvas, tj. je možné kreslit úplně vše. Celé kreslení je virtualizované - tj. při požadavku na kreslení se data vykreslí podle aktualní situace (viz. předchozí články). To umožňuje velmi efektivně měnit prezentaci dat bez změn vlastních dat (zní to komplikovaně, ale znamená to, že data v paměti jsou stále stejná jen se kreslí jak je třeba).

Zdrojové kódy: stáhnout (2K)

Popis na konci programu.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, VirtualTrees;

type
  TForm1 = class(TForm)
    vt: TVirtualDrawTree;
    procedure FormCreate(Sender: TObject);
    procedure vtFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
    procedure vtDrawNode(Sender: TBaseVirtualTree;
      const PaintInfo: TVTPaintInfo);
    procedure vtBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas;
      Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode;
      CellRect: TRect; var ContentRect: TRect);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TItemType = (itRectangle, itOval, itTriangle);

  PTreeItem=^TTreeItem;
  TTreeItem = Record
    item: TItemType;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
  procedure mAddItem(DrawItem: TItemType);
  var
    pNode: PVirtualNode;
    pData: PTreeItem;
  begin
    // uzel
    vt.ChildCount[vt.RootNode] := vt.ChildCount[vt.RootNode] + 1;
    vt.ValidateNode(vt.RootNode, False);

    pNode := vt.RootNode.LastChild;
    pData :=  PTreeItem(vt.GetNodeData(pNode));
    pData^.item := DrawItem;
    vt.NodeHeight[pNode] := 20;
    // poduzel

    vt.ChildCount[pNode] := 1;
    vt.ValidateNode(pNode, True);
    pData :=  PTreeItem(vt.GetNodeData(pNode.FirstChild));
    pData^.item := DrawItem;
    vt.NodeHeight[pNode.FirstChild] := 30; // calculated later
  end;
begin
  vt.NodeDataSize := SizeOf(TTreeItem);
  mAddItem(itRectangle);
  mAddItem(itOval);
  mAddItem(itTriangle);
end;

procedure TForm1.vtBeforeCellPaint(Sender: TBaseVirtualTree;
  TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
  CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect);
var
  Data:PTreeItem;
  r: TRect;
  iHeight: Integer;
begin
  Data:= Sender.GetNodeData(Node);
  if (Data = nil) then
    Exit;
  if vt.GetNodeLevel(Node) <> 1 then // jen child node budeme nastavovat
    Exit;
  case Data^.item of
    itRectangle:
      iHeight := 90;
    itOval:
      iHeight := 20;
    itTriangle:
      iHeight := 50;
  end;

  if vt.NodeHeight[Node] <> iHeight then
    vt.NodeHeight[Node] := iHeight;
end;

procedure TForm1.vtDrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo);
var
  Data:PTreeItem;
  r: TRect;
begin
  Data:= Sender.GetNodeData(PaintInfo.Node);
  if (Data = nil) then
    Exit;
  r := PaintInfo.ContentRect;
  inc(r.Top, 3);
  case vt.GetNodeLevel(PaintInfo.Node) of
  0:
    begin
      PaintInfo.Canvas.Font.Color := clRed;
      case Data^.item of
        itRectangle:
          PaintInfo.Canvas.TextOut(r.Left, r.Top, 'Obdélník');
        itOval:
          PaintInfo.Canvas.TextOut(r.Left, r.Top, 'Ovál');
        itTriangle:
          PaintInfo.Canvas.TextOut(r.Left, r.Top, 'Trojúhelník');
      end;
    end;
  1:begin
      case Data^.item of
        itRectangle:
          begin
            PaintInfo.Canvas.Brush.Color := clGreen;
            PaintInfo.Canvas.Rectangle(r.Left, r.Top, 100, r.Top + 80);
          end;
        itOval:
          begin
            PaintInfo.Canvas.Brush.Color := clYellow;
            PaintInfo.Canvas.Ellipse(r.Left + 20, r.Top, r.Left + 50, r.Bottom);
          end;
        itTriangle:
          begin
            PaintInfo.Canvas.Brush.Color := clGradientActiveCaption;
            PaintInfo.Canvas.Polygon([Point(r.Left, r.Top), Point(r.Left + 40, r.Top), 
              Point(r.Left + 20, r.Bottom)]);
          end;
      end;
    end;
  end;
end;

procedure TForm1.vtFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
  Data:PTreeItem;
begin
  Data:= Sender.GetNodeData(Node);
  if (Data = nil) then
    Exit;
  Finalize(Data^);
end;

end.

Ve FormCreate je stromu nastavena velikost datové struktury (řádek 62) a přidány a inicializovány všechny uzly. Vždy je vytvořen uzel pro text a poduzel pro obrázek.

V metodě vtBeforeCellPaint (obsluha OnBeforeCellPaint) nastavujeme výšku poduzlů v závislosti na datech.

Metoda vtFreeNode (obsluha OnFreeNode) uvolňuje data při uvolnění uzlu z paměti.

Jádrem programu je metoda vtDrawNode (obsluha OnDrawNode). Zde se provádí vlastní kreslení v závislosti na úrovni uzlu (0 - text, 1 - geometrie) a typu v datech (obdélník, ovál nebo trojúhelník). Jak by řekl Zdeněk: je to jednoduché jako žebřík.

Pozn: nepoužíval jsem with, které bych normálně použil a které se zde vyloženě nabízí a to jen z důvodu čtení kódu.

PS: Uvedený program je vykonstruovaný, zde je ale screenshot z našeho CRMplus, kde kromě kreslení (včetně přechodů) je pak i detekce kliknutí na odkaz - to jen pro ukázku, že uvedené je opravdu jen principiální základ.

CRMplus

Tagy: , , ,

Komponenty

Komentování ukončeno

Naše nabídka

MVP
Ing. Radek Červinka - Embarcadero MVP
profil na linkedin, Twitter:@delphicz

Nabízím placené poradenství a konzultace v oblasti programování a vývoje SW.
Dále nabízíme i vývoj speciálního software na zakázku.

Neváhejte nás kontaktovat (i ohledně reklamy).

Pokud chcete podpořit tento server libovolnou částkou, můžete použít PayPal. Moc děkuji.

Delphi Certified Developer

O Delphi.cz

Delphi je jediný moderní RAD nástroj podporující tvorbu nativních aplikací pro platformu Win32, Win64, Mac OSX a na iPhone a Android.

Delphi.cz je nezávislý portál pro uživatele Delphi. Portál není koncipován pro úplné začátečníky, i když i ti se zde nebudou nudit, ale spíše na programátory, kteří již něco znají a chtějí své znalosti dále rozvíjet a sledovat novinky.

Poslední komentáře

Comment RSS