Home: Code Repository: Mastering Delphi 5

Project DRAGTREE

Project Structure

DRAGTREE.DPR
TREEFORM.PAS
TREEFORM.DFM

program DragTree;

uses
  Forms,
  TreeForm in 'TreeForm.pas' {Form1};

{$R *.RES}

begin
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit TreeForm;

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Menus;

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    MainMenu1: TMainMenu;
    Options1: TMenuItem;
    File1: TMenuItem;
    Exit1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    Root1: TMenuItem;
    Buttons1: TMenuItem;
    Lines1: TMenuItem;
    N1: TMenuItem;
    Font1: TMenuItem;
    FontDialog1: TFontDialog;
    procedure FormCreate(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure Root1Click(Sender: TObject);
    procedure Buttons1Click(Sender: TObject);
    procedure Lines1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure Font1Click(Sender: TObject);
    procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  TreeView1.LoadFromFile (
    ExtractFilePath (Application.ExeName) + 'TreeText.txt');
end;

procedure TForm1.About1Click(Sender: TObject);
begin
  MessageDlg ('DragTree Example'#13'by Marco Cant�'  ,
    mtInformation, [mbOk], 0);
end;

procedure TForm1.Root1Click(Sender: TObject);
begin
  TreeView1.ShowRoot := not TreeView1.ShowRoot;
  Root1.Checked := TreeView1.ShowRoot;
end;

procedure TForm1.Buttons1Click(Sender: TObject);
begin
  TreeView1.ShowButtons := not TreeView1.ShowButtons;
  Buttons1.Checked := TreeView1.ShowButtons;
end;

procedure TForm1.Lines1Click(Sender: TObject);
begin
  TreeView1.ShowLines := not TreeView1.ShowLines;
  Lines1.Checked := TreeView1.ShowLines;
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.Font1Click(Sender: TObject);
begin
  if FontDialog1.Execute then
    TreeView1.Font := FontDialog1.Font;
end;

procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var
  TargetNode, SourceNode: TTreeNode;
begin
  TargetNode := TreeView1.GetNodeAt (X, Y);
  // accept dragging from itself
  if (Source = Sender) and (TargetNode <> nil) then
  begin
    Accept := True;
    // determines source and target
    SourceNode := TreeView1.Selected;
    // look up the target parent chain
    while (TargetNode.Parent <> nil) and
        (TargetNode <> SourceNode) do
      TargetNode := TargetNode.Parent;
    // if source is found
    if TargetNode = SourceNode then
      // do not allow dragging over a child
      Accept := False;
  end
  else
    Accept := False;
end;

procedure TForm1.TreeView1DragDrop(Sender, Source: TObject;
  X, Y: Integer);
var
  TargetNode, SourceNode: TTreeNode;
begin
  TargetNode := TreeView1.GetNodeAt (X, Y);
  if TargetNode <> nil then
  begin
    SourceNode := TreeView1.Selected;
    SourceNode.MoveTo (TargetNode, naAddChildFirst);
    TargetNode.Expand (False);
    TreeView1.Selected := TargetNode;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  TreeView1.SaveToFile (
    ExtractFilePath (Application.ExeName) + 'TreeText.txt');
end;

end.

object Form1: TForm1
  Left = 241
  Top = 106
  Width = 440
  Height = 304
  Caption = 'DragTree'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = True
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object TreeView1: TTreeView
    Left = 0
    Top = 0
    Width = 432
    Height = 258
    Align = alClient
    ChangeDelay = 10
    DragMode = dmAutomatic
    Indent = 19
    ParentShowHint = False
    RightClickSelect = True
    ShowHint = True
    TabOrder = 0
    OnDragDrop = TreeView1DragDrop
    OnDragOver = TreeView1DragOver
  end
  object MainMenu1: TMainMenu
    Left = 32
    Top = 8
    object File1: TMenuItem
      Caption = '&File'
      object Exit1: TMenuItem
        Caption = 'E&xit'
        ShortCut = 32883
        OnClick = Exit1Click
      end
    end
    object Options1: TMenuItem
      Caption = '&Options'
      object Root1: TMenuItem
        Caption = '&Root'
        Checked = True
        OnClick = Root1Click
      end
      object Buttons1: TMenuItem
        Caption = '&Buttons'
        Checked = True
        OnClick = Buttons1Click
      end
      object Lines1: TMenuItem
        Caption = '&Lines'
        Checked = True
        OnClick = Lines1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object Font1: TMenuItem
        Caption = 'Font...'
        OnClick = Font1Click
      end
    end
    object Help1: TMenuItem
      Caption = '&Help'
      object About1: TMenuItem
        Caption = '&About...'
        OnClick = About1Click
      end
    end
  end
  object FontDialog1: TFontDialog
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    MinFontSize = 0
    MaxFontSize = 0
    Left = 32
    Top = 56
  end
end