De1uxe

D&D all columns virtual treeview

Jun 9th, 2017
115
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. unit DRAG;
  2.  
  3. interface
  4.  
  5. uses
  6.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  7.   System.Classes, Vcl.Graphics,
  8.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, VirtualTrees, ActiveX, Vcl.StdCtrls,
  9.   Vcl.ButtonGroup, Vcl.ExtCtrls, Vcl.ToolWin, Vcl.ComCtrls, Vcl.Grids,
  10.   Vcl.Outline, Vcl.WinXCtrls, Vcl.ActnMan, Vcl.ActnCtrls, Vcl.ActnMenus,
  11.   System.Actions, Vcl.ActnList, Vcl.PlatformDefaultStyleActnCtrls, XML.XMLIntf,
  12.   XML.XMLDoc;
  13.  
  14. type
  15.   PItemNode1 = ^TItemNode1;
  16.  
  17.   TItemNode1 = record
  18.     Name: String;
  19.     Order: string;
  20.   end;
  21.  
  22. type
  23.   PItemNode2 = ^TItemNode2;
  24.  
  25.   TItemNode2 = record
  26.     Name: String;
  27.     Order: string;
  28.   end;
  29.  
  30. type
  31.   TForm1 = class(TForm)
  32.     VT: TVirtualStringTree;
  33.     VT2: TVirtualStringTree;
  34.     Button1: TButton;
  35.     Button2: TButton;
  36.     Panel1: TPanel;
  37.     Timer1: TTimer;
  38.     Splitter1: TSplitter;
  39.     ActionManager1: TActionManager;
  40.     ActionNew: TAction;
  41.     ActionOpen: TAction;
  42.     ActionSave: TAction;
  43.     ActionSaveAs: TAction;
  44.     ActionExit: TAction;
  45.     ActionCopy: TAction;
  46.     ActionPaste: TAction;
  47.     ActionVisibleToolBar: TAction;
  48.     ActionList1: TActionList;
  49.     NewAction: TAction;
  50.     OpenAction: TAction;
  51.     SaveAction: TAction;
  52.     SaveAsAction: TAction;
  53.     ExitAction: TAction;
  54.     Label1: TLabel;
  55.     procedure FormCreate(Sender: TObject);
  56.     procedure VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  57.       Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
  58.     procedure VT2NewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  59.       Column: TColumnIndex; NewText: string);
  60.     procedure VT2GetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  61.       Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
  62.     procedure VT2InitNode(Sender: TBaseVirtualTree;
  63.       ParentNode, Node: PVirtualNode;
  64.       var InitialStates: TVirtualNodeInitStates);
  65.     procedure VTDragDrop(Sender: TBaseVirtualTree; Source: TObject;
  66.       DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
  67.       Pt: TPoint; var Effect: Integer; Mode: TDropMode);
  68.  
  69.     procedure InsertData(Sender: TVirtualStringTree; DataObject: IDataObject;
  70.       Formats: TFormatArray; Effect: Integer; Mode: TVTNodeAttachMode);
  71.     procedure VTDragOver(Sender: TBaseVirtualTree; Source: TObject;
  72.       Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
  73.       var Effect: Integer; var Accept: Boolean);
  74.     procedure VT2DragOver(Sender: TBaseVirtualTree; Source: TObject;
  75.       Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
  76.       var Effect: Integer; var Accept: Boolean);
  77.     procedure VT2DragDrop(Sender: TBaseVirtualTree; Source: TObject;
  78.       DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
  79.       Pt: TPoint; var Effect: Integer; Mode: TDropMode);
  80.     procedure VT2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode;
  81.       Column: TColumnIndex; var Allowed: Boolean);
  82.     procedure VT2BeforeItemErase(Sender: TBaseVirtualTree;
  83.       TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect;
  84.       var ItemColor: TColor; var EraseAction: TItemEraseAction);
  85.     procedure Button1Click(Sender: TObject);
  86.     procedure VT2SaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
  87.       Stream: TStream);
  88.     procedure VT2LoadNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
  89.       Stream: TStream);
  90.     procedure Button2Click(Sender: TObject);
  91.     procedure Timer1Timer(Sender: TObject);
  92.     procedure VTNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  93.       Column: TColumnIndex; NewText: string);
  94.     procedure VTInitNode(Sender: TBaseVirtualTree;
  95.       ParentNode, Node: PVirtualNode;
  96.       var InitialStates: TVirtualNodeInitStates);
  97.     procedure StringToStream(const Astr: string; Stream: TStream);
  98.     procedure StreamToString(var Astr: string; Stream: TStream);
  99.     procedure RecordToXML(const Rec: PItemNode1; RootNode: IXMLNode);
  100.     procedure XMLToRecord(var Rec: PItemNode2; RootNode: IXMLNode);
  101.     procedure VTSaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
  102.       Stream: TStream);
  103.  
  104.   private
  105.     { Private declarations }
  106.   public
  107.     { Public declarations }
  108.   end;
  109.  
  110. var
  111.   Form1: TForm1;
  112.  
  113. implementation
  114.  
  115. {$R *.dfm}
  116.  
  117. procedure TForm1.Button1Click(Sender: TObject);
  118. begin
  119.   VT2.SaveToFile('mySave.feproj');
  120. end;
  121.  
  122. procedure TForm1.Button2Click(Sender: TObject);
  123. begin
  124.   VT2.LoadFromFile('mySave.feproj');
  125. end;
  126.  
  127. procedure TForm1.FormCreate(Sender: TObject);
  128. var
  129.   Node: PVirtualNode;
  130.   i: Integer;
  131.   ItemNode: PItemNode1;
  132. begin
  133.   VT.NodeDataSize := SizeOf(TItemNode1);
  134.   VT2.NodeDataSize := SizeOf(TItemNode2);
  135.   VT.RootNodeCount := 2;
  136.   VT2.RootNodeCount := 10;
  137.   {
  138.     Node := VT.AddChild(VT.RootNode);
  139.     if not(vsInitialized in Node.States) then
  140.     VT.ReinitNode(Node, false);
  141.     ItemNode := VT.GetNodeData(Node);
  142.     ItemNode.Name := 'Узел';
  143.     ItemNode.Order := '111'; }
  144.  
  145. end;
  146.  
  147. procedure TForm1.InsertData(Sender: TVirtualStringTree; DataObject: IDataObject;
  148.   Formats: TFormatArray; Effect: Integer; Mode: TVTNodeAttachMode);
  149. var
  150.   FormatAccepted: Boolean; // True, если принятые данные уже обработались
  151.   i: Integer;
  152. begin
  153.   // Ищем в переданных форматах тот, который можем обработать
  154.   FormatAccepted := false;
  155.   for i := 0 to High(Formats) do
  156.   begin
  157.     if Formats[i] = CF_VIRTUALTREE then
  158.     // Родной формат VT. Обрабатывает вставку своих же
  159.     // TVirtualNode-узлов.
  160.     begin
  161.       if not FormatAccepted then
  162.       begin
  163.         Sender.ProcessDrop(DataObject, Sender.DropTargetNode, Effect, Mode);
  164.         FormatAccepted := True;
  165.       end;
  166.     end;
  167.   end;
  168. end;
  169.  
  170. procedure TForm1.Timer1Timer(Sender: TObject);
  171. var
  172.   y, a: Integer;
  173.   po, Cpo: TPoint;
  174.   con: TControl;
  175. begin
  176.   { GetCursorPos(po);
  177.     y:=po.y;
  178.     po:=ScreenToClient(po);
  179.     Cpo:=Form1.ClientOrigin;
  180.     con:=Form1.ControlAtPos(po,True,True);
  181.     if (con<>nil) and (y>Cpo.y) and (y<Cpo.y+Form1.ClientHeight) then begin
  182.     if (con.Name='Panel1') or (con.Parent.Name='Panel1') then begin
  183.     if Panel1.Left>Form1.ClientWidth-Panel1.Width then
  184.     if Panel1.Left+Panel1.Width-3>Form1.ClientWidth then Panel1.Left:= Panel1.Left-3  //показать
  185.     else Panel1.Left:=Form1.ClientWidth-Panel1.Width;
  186.     end;
  187.     end
  188.     else begin
  189.     a:=Form1.ClientWidth-7;
  190.     if Panel1.Left<a then
  191.     if Panel1.Left+3<a then Panel1.Left:= Panel1.Left+3 //убрать
  192.     else Panel1.Left:=a;
  193.     end; }
  194. end;
  195.  
  196. procedure TForm1.VT2BeforeItemErase(Sender: TBaseVirtualTree;
  197.   TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect;
  198.   var ItemColor: TColor; var EraseAction: TItemEraseAction);
  199. // The second tree uses manual drag and we want to show the lines which are allowed to start a drag operation by
  200. // a colored background.
  201.  
  202. begin
  203.   if Odd(Node.Index) then
  204.   begin
  205.     ItemColor := $FFEEEE;
  206.     EraseAction := eaColor;
  207.   end;
  208. end;
  209.  
  210. procedure TForm1.VT2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode;
  211.   Column: TColumnIndex; var Allowed: Boolean);
  212. begin
  213.   Allowed := True;
  214. end;
  215.  
  216. procedure TForm1.VT2DragDrop(Sender: TBaseVirtualTree; Source: TObject;
  217.   DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
  218.   Pt: TPoint; var Effect: Integer; Mode: TDropMode);
  219.   procedure DetermineEffect;
  220.   begin
  221.     // Нажаты ли какие-нибудь управляющие клавиши?
  222.     if Shift = [] then
  223.     begin
  224.       // Неа, не нажаты
  225.       // Тогда, если отправитель и получатель - одинаковые объекты (например,
  226.       // если узлы перемещаются из одного и того же дерева), то
  227.       // надо переместить узлы, в противном случае - копировать.
  228.       if Source = Sender then
  229.         Effect := DROPEFFECT_MOVE
  230.       else
  231.         Effect := DROPEFFECT_COPY;
  232.     end
  233.     else
  234.     begin
  235.       // Нажаты. В зависмости от комбинации решаем что делать
  236.       if (Shift = [ssAlt]) or (Shift = [ssCtrl, ssAlt]) then
  237.         Effect := DROPEFFECT_LINK
  238.       else if Shift = [ssCtrl] then
  239.         Effect := DROPEFFECT_COPY
  240.       else
  241.         // Effect := DROPEFFECT_MOVE;
  242.     end;
  243.   end;
  244.  
  245. var
  246.   Attachmode: TVTNodeAttachMode;
  247.   Nodes: TNodeArray;
  248.   i: Integer;
  249. begin
  250.   Nodes := nil;
  251.   // Определяем, куда добавлять узел в зависимости от того, куда была
  252.   // брошена ветка.
  253.   case Mode of
  254.     dmAbove:
  255.       Attachmode := amInsertBefore;
  256.     dmOnNode:
  257.       Attachmode := amAddChildLast;
  258.     dmBelow:
  259.       Attachmode := amInsertAfter;
  260.   else
  261.     Attachmode := amNowhere;
  262.   end;
  263.   if DataObject = nil then
  264.   begin
  265.     // Если не пришло интерфейса, то вставка проходит через VCL метод
  266.     if Source is TVirtualStringTree then
  267.     begin
  268.       // Вставка из VT. Можем спокойно пользоваться его методами
  269.       // копирования и перемещения.
  270.       DetermineEffect;
  271.       // Получаем список узлов, которые будут участвовать в Drag&Drop
  272.       Nodes := VT2.GetSortedSelection(True);
  273.       // И работаем с каждым
  274.       if Effect = DROPEFFECT_COPY then
  275.       begin
  276.         for i := 0 to High(Nodes) do
  277.           VT2.CopyTo(Nodes[i], Sender.DropTargetNode, Attachmode, false);
  278.       end
  279.       else
  280.         for i := 0 to High(Nodes) do
  281.           VT2.MoveTo(Nodes[i], Sender.DropTargetNode, Attachmode, false);
  282.     end;
  283.   end
  284.   else
  285.   begin
  286.     // OLE drag&drop.
  287.     // Effect нужен для передачи его источнику drag&drop, чтобы тот решил
  288.     // что он будет делать со своими перетаскиваемыми данными.
  289.     // Например, при DROPEFFECT_MOVE (перемещение) их нужно будет удалить,
  290.     // при копировании - сохранить.
  291.     if Source is TBaseVirtualTree then
  292.       DetermineEffect
  293.     else
  294.     begin
  295.       if Boolean(Effect and DROPEFFECT_COPY) then
  296.         Effect := DROPEFFECT_COPY
  297.       else
  298.         Effect := DROPEFFECT_MOVE;
  299.     end;
  300.     InsertData(Sender as TVirtualStringTree, DataObject, Formats, Effect,
  301.       Attachmode);
  302.   end;
  303. end;
  304.  
  305. procedure TForm1.VT2DragOver(Sender: TBaseVirtualTree; Source: TObject;
  306.   Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
  307.   var Effect: Integer; var Accept: Boolean);
  308. // Возвращает True, если AParent - дочерний узел ANode.
  309.   function IsNodeParent(AParent, ANode: PVirtualNode): Boolean;
  310.   var
  311.     NextParent: PVirtualNode;
  312.   begin
  313.     NextParent := AParent;
  314.     repeat
  315.       NextParent := NextParent.Parent;
  316.     until (NextParent = Sender.RootNode) or (NextParent = nil) or
  317.       (NextParent = ANode);
  318.     Result := ANode = NextParent;
  319.   end;
  320.  
  321. var
  322.   i: Integer;
  323.   Nodes: TNodeArray;
  324. begin
  325.   Accept := True;
  326.   if (Assigned(Sender.DropTargetNode)) and
  327.     (Sender.DropTargetNode <> Sender.RootNode) then
  328.     Nodes := (Sender as TVirtualStringTree).GetSortedSelection(True);
  329.   if Length(Nodes) > 0 then
  330.   begin
  331.     for i := 0 to Length(Nodes) - 1 do
  332.     begin
  333.       Accept :=
  334.       // Узел не должен быть родителем ветки, в которую производится
  335.       // вставка
  336.         (not IsNodeParent(Sender.DropTargetNode, Nodes[i]))
  337.       // Также, узел не должен равняться ветке-местоназначению вставки.
  338.       // Т.е. мы должны запретить вставку узла в самого себя.
  339.         and (not(Sender.DropTargetNode = Nodes[i]));
  340.       // Отключаем вставку, если хотя бы одно из условий вернуло False
  341.       if not Accept then
  342.         Exit;
  343.     end;
  344.   end;
  345. end;
  346.  
  347. procedure TForm1.VT2GetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  348.   Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
  349. var
  350.   ItemNode: PItemNode2;
  351.  
  352. begin
  353.   ItemNode := Sender.GetNodeData(Node);
  354.   if Assigned(ItemNode) then
  355.   begin
  356.     case Column of
  357.       0:
  358.         CellText := ItemNode^.Name;
  359.       1:
  360.         CellText := ItemNode^.Order;
  361.     end;
  362.   end;
  363. end;
  364.  
  365. procedure TForm1.VT2InitNode(Sender: TBaseVirtualTree;
  366.   ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
  367. var
  368.   ItemNode: PItemNode2;
  369. begin
  370.   ItemNode := Sender.GetNodeData(Node);
  371.   if Assigned(ItemNode) then
  372.     if Length(ItemNode^.Name) = 0 then
  373.       ItemNode^.Name := 'Node Index № ' + IntToStr(Node.Index);
  374.   ItemNode^.Order := IntToStr(Node.Index);
  375. end;
  376.  
  377. procedure TForm1.VT2NewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  378.   Column: TColumnIndex; NewText: string);
  379. var
  380.   ItemNode: PItemNode2;
  381. begin
  382.   { ItemNode := Sender.GetNodeData(Node);
  383.     if Assigned(ItemNode) then
  384.     begin
  385.     case Column of
  386.     0:
  387.     ItemNode^.Name := NewText;
  388.     1:
  389.     ItemNode^.Order := NewText;
  390.     end;
  391.     Label1.Caption := ItemNode^.Order;
  392.     end; }
  393. end;
  394.  
  395. procedure TForm1.VTDragDrop(Sender: TBaseVirtualTree; Source: TObject;
  396.   DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
  397.   Pt: TPoint; var Effect: Integer; Mode: TDropMode);
  398. {$REGION 'ЗАКОМЕНЧЕНА процедура DetermineEffect'}
  399. // Определяем как поступать с данными. Перемещать, копировать или ссылаться
  400. { procedure DetermineEffect;
  401.   begin
  402.   // Нажаты ли какие-нибудь управляющие клавиши?
  403.   if Shift = [] then
  404.   begin
  405.   // Неа, не нажаты
  406.   // Тогда, если отправитель и получатель - одинаковые объекты (например,
  407.   // если узлы перемещаются из одного и того же дерева), то
  408.   // надо переместить узлы, в противном случае - копировать.
  409.   if Source = Sender then
  410.   Effect := DROPEFFECT_MOVE
  411.   else
  412.   Effect := DROPEFFECT_COPY;
  413.   end
  414.   else begin
  415.   // Нажаты. В зависмости от комбинации решаем что делать
  416.   if Shift = [ssCtrl] then
  417.   Effect := DROPEFFECT_COPY
  418.   else
  419.   // Effect := DROPEFFECT_MOVE;
  420.   end;
  421.   end;
  422. }
  423. {$ENDREGION}
  424. var
  425.   Attachmode: TVTNodeAttachMode;
  426.   Nodes: TNodeArray;
  427.   i: Integer;
  428. begin
  429.   Nodes := nil;
  430.   // Определяем, куда добавлять узел в зависимости от того, куда была
  431.   // брошена ветка.
  432.   case Mode of
  433.     dmAbove:
  434.       Attachmode := amInsertBefore;
  435.     dmOnNode:
  436.       Attachmode := amAddChildLast;
  437.     dmBelow:
  438.       Attachmode := amInsertAfter;
  439.   else
  440.     // AttachMode := amNowhere;
  441.   end;
  442. {$REGION 'ЗАКОМЕНЧЕНО'}
  443.   { if DataObject = nil then
  444.     begin
  445.     // Если не пришло интерфейса, то вставка проходит через VCL метод
  446.     if Source is TVirtualStringTree then
  447.     begin
  448.     // Вставка из VT. Можем спокойно пользоваться его методами
  449.     // копирования и перемещения.
  450.     DetermineEffect;
  451.     // Получаем список узлов, которые будут участвовать в Drag&Drop
  452.     Nodes := VT2.GetSortedSelection(True);
  453.     // И работаем с каждым
  454.     if Effect = DROPEFFECT_COPY then
  455.     begin
  456.     for i := 0 to High(Nodes) do
  457.     VT2.CopyTo(Nodes[i], Sender.DropTargetNode, AttachMode, False);
  458.     end
  459.     else
  460.     for i := 0 to High(Nodes) do
  461.     VT2.MoveTo(Nodes[i], Sender.DropTargetNode, AttachMode, False);
  462.     end;
  463.     // else if Source is TListBox then
  464.     // begin
  465.     // Вставка из объекта какого-то другого класса
  466.     //    AddVCLText(Sender as TVirtualStringTree,
  467.     //      (Source as TListBox).Items.Strings[(Source as TListBox).ItemIndex],
  468.     //      AttachMode);
  469.     //  end;
  470.     end
  471.     else begin }
  472.   // OLE drag&drop.
  473.   // Effect нужен для передачи его источнику drag&drop, чтобы тот решил
  474.   // что он будет делать со своими перетаскиваемыми данными.
  475.   // Например, при DROPEFFECT_MOVE (перемещение) их нужно будет удалить,
  476.   // при копировании - сохранить.
  477. {$ENDREGION}
  478.   if Source is TBaseVirtualTree then
  479. {$REGION 'И еще вот тут закоменчено'}
  480.     // DetermineEffect;
  481.     { else begin
  482.       if Boolean(Effect and DROPEFFECT_COPY) then
  483.       Effect := DROPEFFECT_COPY
  484.       else
  485.       Effect := DROPEFFECT_MOVE;
  486.       end; }
  487. {$ENDREGION}
  488.     InsertData(Sender as TVirtualStringTree, DataObject, Formats, Effect,
  489.       Attachmode);
  490. end;
  491. // end;
  492.  
  493. // -----------------------------------------------------------------------------
  494. // ---------------------------------------------------------------------------
  495. // В этом событии мы должны проверить есть ли среди перетаскиваемых веток
  496. // родитель ветки, в которую происходит перетаскивание. Ведь нельзя
  497. // же ветку-родитель перетащить в ее дочерние элементы
  498. // ---------------------------------------------------------------------------
  499.  
  500. procedure TForm1.VTDragOver(Sender: TBaseVirtualTree; Source: TObject;
  501.   Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
  502.   var Effect: Integer; var Accept: Boolean);
  503.  
  504. // Возвращает True, если AParent - дочерний узел ANode.
  505.   function IsNodeParent(AParent, ANode: PVirtualNode): Boolean;
  506.   var
  507.     NextParent: PVirtualNode;
  508.     ItemNode: PItemNode1;
  509.   begin
  510.     NextParent := AParent;
  511. {$REGION 'определение иемения взятого узла'}
  512.     ItemNode := Sender.GetNodeData(ANode);
  513.     if Assigned(ItemNode) then
  514.       if ItemNode^.Name = 'Node Index № 0' then
  515.         Form1.Caption := 'МЫ ВЗЯЛИ УЗЕЛ под названием' + ItemNode^.Name;
  516. {$ENDREGION}
  517.     repeat
  518.       NextParent := NextParent.Parent;
  519.     until (NextParent = Sender.RootNode) or (NextParent = nil) or
  520.       (NextParent = ANode);
  521.     Result := ANode = NextParent;
  522.   end;
  523.  
  524. var
  525.   i: Integer;
  526.   Nodes: TNodeArray;
  527. begin
  528.   Accept := True;
  529.   if (Assigned(Sender.DropTargetNode)) and
  530.     (Sender.DropTargetNode <> Sender.RootNode) then
  531.     Nodes := (Sender as TVirtualStringTree).GetSortedSelection(True);
  532.   if Length(Nodes) > 0 then
  533.   begin
  534.     for i := 0 to Length(Nodes) - 1 do
  535.     begin
  536.       Accept :=
  537.       // Узел не должен быть родителем ветки, в которую производится
  538.       // вставка
  539.         (not IsNodeParent(Sender.DropTargetNode, Nodes[i]))
  540.       // Также, узел не должен равняться ветке-местоназначению вставки.
  541.       // Т.е. мы должны запретить вставку узла в самого себя.
  542.         and (not(Sender.DropTargetNode = Nodes[i]));
  543.       // Отключаем вставку, если хотя бы одно из условий вернуло False
  544.       if not Accept then
  545.         Exit;
  546.     end;
  547.   end;
  548. end;
  549.  
  550. procedure TForm1.VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  551.   Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
  552. var
  553.   ItemNode: PItemNode1;
  554. begin
  555.  
  556.   ItemNode := Sender.GetNodeData(Node);
  557.   if Assigned(ItemNode) then
  558.  
  559.     case Column of
  560.       0:
  561.         CellText := ItemNode^.Name;
  562.       1:
  563.         begin
  564.           // ItemNode^.Order:=111;
  565.           CellText := ItemNode^.Order;
  566.         end;
  567.     end;
  568. end;
  569.  
  570. procedure TForm1.VTInitNode(Sender: TBaseVirtualTree;
  571.   ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
  572. var
  573.   ItemNode: PItemNode1;
  574. begin
  575.   ItemNode := Sender.GetNodeData(Node);
  576.   if Assigned(ItemNode) then
  577.     if Length(ItemNode^.Name) = 0 then
  578.       ItemNode^.Name := 'VT1_Node № ' + IntToStr(Node.Index);
  579.   ItemNode^.Order := IntToStr(Node.Index);
  580. end;
  581.  
  582. procedure TForm1.VTNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
  583.   Column: TColumnIndex; NewText: string);
  584. var
  585.   ItemNode: PItemNode1;
  586. begin
  587.   ItemNode := Sender.GetNodeData(Node);
  588.   if Assigned(ItemNode) then
  589.     ItemNode^.Name := NewText;
  590. end;
  591.  
  592. // ---------------------------------------------------------------------------
  593. // Метод для сохранения данных из строковой переменной в поток
  594. // ---------------------------------------------------------------------------
  595. procedure TForm1.StringToStream(const Astr: string; Stream: TStream);
  596. var
  597.   Bytes: TBytes;
  598.   i: Integer;
  599. begin
  600.   Bytes := TEncoding.UTF8.GetBytes(Astr);
  601.   i := Length(Bytes);
  602.   Stream.Write(i, SizeOf(Integer));
  603.   if i > 0 then
  604.     Stream.WriteBuffer(Bytes[0], i);
  605. end;
  606.  
  607. // ---------------------------------------------------------------------------
  608. // Метод для сохранения данных потока в строковую переменную
  609. // ---------------------------------------------------------------------------
  610. procedure TForm1.StreamToString(var Astr: string; Stream: TStream);
  611. var
  612.   Bytes: TBytes;
  613.   i: Integer;
  614. begin
  615.   Stream.Read(i, SizeOf(Integer));
  616.   SetLength(Bytes, i);
  617.   if i > 0 then
  618.     Stream.ReadBuffer(Bytes[0], i);
  619.  
  620.   Astr := TEncoding.UTF8.GetString(Bytes);
  621. end;
  622.  
  623. // ---------------------------------------------------------------------------
  624. // Метод для сохранения данных из нашей структуры в XML
  625. // ---------------------------------------------------------------------------
  626. procedure TForm1.RecordToXML(const Rec: PItemNode1; RootNode: IXMLNode);
  627. begin
  628.   RootNode.AddChild('Name').Text := Rec^.Name; // вот здесь в отладчике возникает исключение.
  629.                                                // Если ставлю вот так RootNode.AddChild('Name').Text := 'lalala';
  630.                                                // то исключение не возникает, но возникает в методе XMLToRecord
  631.   // RootNode.AddChild('Order').Text:=Rec^.Order;
  632. end;
  633.  
  634. // ---------------------------------------------------------------------------
  635. // Метод для сохранения данных из XML в нашу структуру
  636. // ---------------------------------------------------------------------------
  637. procedure TForm1.XMLToRecord(var Rec: PItemNode2; RootNode: IXMLNode);
  638. begin
  639.   Rec^.Name := RootNode.ChildNodes.FindNode('Name').Text;
  640.   // Rec.Order:=RootNode.ChildNodes.FindNode('Order').Text;
  641. end;
  642.  
  643. // ---------------------------------------------------------------------------
  644. // Метод VT1_SaveNode ИСТОЧНИК
  645. // ---------------------------------------------------------------------------
  646. procedure TForm1.VTSaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
  647.   Stream: TStream);
  648. var
  649.   XML: IXMLDocument;
  650.   XMLNode: IXMLNode;
  651.   Rec: PItemNode1;
  652.   s: string;
  653. begin
  654.   XML := NewXMLDocument;
  655.   XMLNode := XML.AddChild('root');
  656.   // тут получаем нужный record из Sender-а, и потом:
  657.   RecordToXML(Rec, XMLNode); // записали в XML-контейнер
  658.  
  659.   XML.SaveToXML(s);
  660.   StringToStream(s, Stream); // всё, наш контейнер с данными ушел блуждать
  661.   // по внутренностям механизма Drag&Drop
  662. end;
  663.  
  664. // ---------------------------------------------------------------------------
  665. // Метод VT2_LoadNode    ПРИЕМНИК
  666. // ---------------------------------------------------------------------------
  667. procedure TForm1.VT2LoadNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
  668.   Stream: TStream);
  669. var
  670.   Reader: TReader;
  671.   NewNode: PItemNode2;
  672.  
  673.   XML: IXMLDocument;
  674.   XMLNode: IXMLNode;
  675.   Rec: PItemNode2;
  676.   s: string;
  677. begin
  678.   {
  679.     //загрузка дерева из файла. Сохранение см. VT2_SaveNode
  680.     Reader := TReader.Create(Stream, 1024);
  681.     NewNode := Sender.GetNodeData(Node);
  682.     NewNode.Name := Reader.ReadString;
  683.     NewNode.Order := Reader.ReadString;
  684.     FreeAndNil(Reader); }
  685.  
  686.   // Stream.Position:=0;
  687.   StreamToString(s, Stream);
  688.   // возможно - перед этим стоит сделать Stream.Position:=0;
  689.   XML := LoadXMLData(s);
  690.   XMLNode := XML.DocumentElement;
  691.   // получаем Rec и потом:
  692.   XMLToRecord(Rec, XMLNode);
  693.  
  694. end;
  695.  
  696. // ---------------------------------------------------------------------------
  697. // Метод VT2_SaveNode    Для сохранения дерева в файл
  698. // ---------------------------------------------------------------------------
  699. procedure TForm1.VT2SaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
  700.   Stream: TStream);
  701. var
  702.   Writer: TWriter;
  703.   NewNode: PItemNode2;
  704. begin
  705. {
  706.   Writer := TWriter.Create(Stream, 8096);
  707.   NewNode := Sender.GetNodeData(Node);
  708.   Writer.WriteString(NewNode.Name);
  709.   Writer.WriteString(NewNode.Order);
  710.   FreeAndNil(Writer);
  711.  
  712. }
  713. end;
  714.  
  715. end.
RAW Paste Data