examples/ibtreeview/Unit1.pas

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  StdCtrls, DbCtrls, ActnList, Menus, db, IBTreeView, IBDatabase,
  IBCustomDataSet, IBLookupComboEditBox, IBQuery, IBDynamicGrid, ComCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    AddFirstChild: TAction;
    AddSibling: TAction;
    AddChild: TAction;
    DeleteNode: TAction;
    ActionList1: TActionList;
    ApplicationProperties1: TApplicationProperties;
    DataSource2: TDataSource;
    DataSource3: TDataSource;
    DBEdit1: TDBEdit;
    DBEdit2: TDBEdit;
    DBEdit3: TDBEdit;
    DBEdit4: TDBEdit;
    DepartmentsCHILDCOUNT: TIntegerField;
    IBDynamicGrid1: TIBDynamicGrid;
    IBLookupComboEditBox1: TIBLookupComboEditBox;
    ImageList1: TImageList;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    PopupMenu1: TPopupMenu;
    Staff: TIBQuery;
    Label7: TLabel;
    Managers: TIBQuery;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Panel3: TPanel;
    SaveBtn: TButton;
    CancelBtn: TButton;
    DataSource1: TDataSource;
    DepartmentsBUDGET: TIBBCDField;
    DepartmentsDEPARTMENT: TIBStringField;
    DepartmentsDEPT_NO: TIBStringField;
    DepartmentsHEAD_DEPT: TIBStringField;
    DepartmentsLOCATION: TIBStringField;
    DepartmentsMNGR_NO: TSmallintField;
    DepartmentsPHONE_NO: TIBStringField;
    IBDatabase1: TIBDatabase;
    Departments: TIBDataSet;
    IBTransaction1: TIBTransaction;
    IBTreeView1: TIBTreeView;
    Label1: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    Splitter1: TSplitter;
    StaffDEPT_NO: TIBStringField;
    StaffEMP_NO: TSmallintField;
    StaffFIRST_NAME: TIBStringField;
    StaffFULL_NAME: TIBStringField;
    StaffHIRE_DATE: TDateTimeField;
    StaffJOB_CODE: TIBStringField;
    StaffJOB_COUNTRY: TIBStringField;
    StaffJOB_GRADE: TSmallintField;
    StaffLAST_NAME: TIBStringField;
    StaffPHONE_EXT: TIBStringField;
    StaffSALARY: TIBBCDField;
    procedure AddChildExecute(Sender: TObject);
    procedure AddFirstChildExecute(Sender: TObject);
    procedure AddSiblingExecute(Sender: TObject);
    procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
    procedure CancelBtnClick(Sender: TObject);
    procedure DeleteNodeExecute(Sender: TObject);
    procedure DeleteNodeUpdate(Sender: TObject);
    procedure DepartmentsAfterDelete(DataSet: TDataSet);
    procedure DepartmentsAfterInsert(DataSet: TDataSet);
    procedure DepartmentsAfterTransactionEnd(Sender: TObject);
    procedure DepartmentsBUDGETChange(Sender: TField);
    procedure DepartmentsBUDGETGetText(Sender: TField; var aText: string;
      DisplayText: Boolean);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure IBTreeView1Addition(Sender: TObject; Node: TTreeNode);
    procedure IBTreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure IBTreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure SaveBtnClick(Sender: TObject);
  private
    { private declarations }
    FDirty: boolean;
    FClosing: boolean;
    procedure Reopen(Data: PtrInt);
    procedure SetNodeImage(Node: TTreeNode);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

uses IB;

{ TForm1 }

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  FClosing := true;
  if IBTransaction1.Intransaction then
    IBTransaction1.Commit;
end;

procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
begin
  SaveBtn.Enabled := FDirty;
  CancelBtn.Enabled := FDirty
end;

procedure TForm1.AddChildExecute(Sender: TObject);
begin
  IBTreeView1.Selected.Expand(true);
  IBTreeView1.Selected := IBTreeView1.Items.AddChild(IBTreeView1.Selected,'');
  IBTreeView1.Selected.Expand(true);
  IBTreeView1.Selected.EditText;
end;

procedure TForm1.AddFirstChildExecute(Sender: TObject);
begin
  IBTreeView1.Selected.Expand(true);
  IBTreeView1.Selected := IBTreeView1.Items.AddChildFirst(IBTreeView1.Selected,'');
  IBTreeView1.Selected.Expand(true);
  IBTreeView1.Selected.EditText;
end;

procedure TForm1.AddSiblingExecute(Sender: TObject);
begin
  IBTreeView1.Selected := IBTreeView1.Items.Add(IBTreeView1.Selected,'');
  IBTreeView1.Selected.EditText;
end;

procedure TForm1.CancelBtnClick(Sender: TObject);
begin
  IBTransaction1.Rollback
end;

procedure TForm1.DeleteNodeExecute(Sender: TObject);
begin
  if MessageDlg(Format('Do you want to delete the %s department?',[IBTreeview1.Selected.Text]),
              mtConfirmation,[mbYes,mbNo],0) = mrYes then
    TIBTreeNode(IBTreeview1.Selected).DeleteAll
end;

procedure TForm1.DeleteNodeUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := IBTreeView1.Selected <> nil
end;

procedure TForm1.DepartmentsAfterDelete(DataSet: TDataSet);
begin
  FDirty := true
end;

procedure TForm1.DepartmentsAfterInsert(DataSet: TDataSet);
begin
  FDirty := true;
  DataSet.FieldByName('Department').AsString := 'Dept ' + DataSet.FieldByName('DEPT_NO').AsString
end;

procedure TForm1.DepartmentsAfterTransactionEnd(Sender: TObject);
begin
  if not FClosing then
    Application.QueueAsyncCall(@Reopen,0);
end;

procedure TForm1.DepartmentsBUDGETChange(Sender: TField);
begin
  SetNodeImage(IBTreeView1.Selected)
end;

procedure TForm1.DepartmentsBUDGETGetText(Sender: TField; var aText: string;
  DisplayText: Boolean);
begin
  if DisplayText and not Sender.IsNull then
    aText := FormatFloat('$#,##0.00',Sender.AsFloat)
  else
    aText := Sender.AsString
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  repeat
    try
      IBDatabase1.Connected := true;
    except
     on E:EIBClientError do
      begin
        Close;
        Exit
      end;
    On E:Exception do
     MessageDlg(E.Message,mtError,[mbOK],0);
    end;
  until IBDatabase1.Connected;
  Reopen(0);
end;

procedure TForm1.IBTreeView1Addition(Sender: TObject; Node: TTreeNode);
begin
  SetNodeImage(Node)
end;

procedure TForm1.IBTreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var Node: TTreeNode;
    tv: TTreeView;
begin
  if Source = Sender then {Dragging within Tree View}
  begin
    tv := TTreeView(Sender);;
    Node := tv.GetNodeAt(X,Y); {Drop Point}
    if assigned(tv.Selected) and (tv.Selected <> Node) then
    begin
      if Node = nil then
        tv.Selected.MoveTo(nil,naAdd) {Move to Top Level}
      else
      begin
        if ssCtrl in GetKeyShiftState then
        begin
          Node.Expand(false);
          tv.Selected.MoveTo(Node,naAddChildFirst)
        end
        else
          tv.Selected.MoveTo(Node,naInsertBehind)
      end;
    end;
  end;
end;

procedure TForm1.IBTreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source = Sender
end;

procedure TForm1.SaveBtnClick(Sender: TObject);
begin
  IBtransaction1.Commit
end;

procedure TForm1.Reopen(Data: PtrInt);
begin
  FDirty := false;
  IBTransaction1.StartTransaction;
  Managers.Active := true;
  Departments.Active := true;
  Staff.Active := true;
end;

procedure TForm1.SetNodeImage(Node: TTreeNode);
begin
  if Departments.FieldByName('Budget').AsFloat < 500000 then
     Node.ImageIndex := 0
  else
  if Departments.FieldByName('Budget').AsFloat = 500000 then
    Node.ImageIndex := 2
  else
    Node.ImageIndex := 1
end;

end.

Revision:	27
Committed:	Tue Apr 14 13:10:23 2015 UTC (9 years ago) by tony
Content type:	text/x-pascal
File size:	7565 byte(s)
Log Message:	Committing updates for Release R1-2-3
#	User	Rev	Content
1	tony	21	unit Unit1;
2
3			{$mode objfpc}{$H+}
4
5			interface
6
7			uses
8			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
9			StdCtrls, DbCtrls, ActnList, Menus, db, IBTreeView, IBDatabase,
10			IBCustomDataSet, IBLookupComboEditBox, IBQuery, IBDynamicGrid, ComCtrls;
11
12			type
13
14			{ TForm1 }
15
16			TForm1 = class(TForm)
17			AddFirstChild: TAction;
18			AddSibling: TAction;
19			AddChild: TAction;
20			DeleteNode: TAction;
21			ActionList1: TActionList;
22			ApplicationProperties1: TApplicationProperties;
23			DataSource2: TDataSource;
24			DataSource3: TDataSource;
25			DBEdit1: TDBEdit;
26			DBEdit2: TDBEdit;
27			DBEdit3: TDBEdit;
28			DBEdit4: TDBEdit;
29			DepartmentsCHILDCOUNT: TIntegerField;
30			IBDynamicGrid1: TIBDynamicGrid;
31			IBLookupComboEditBox1: TIBLookupComboEditBox;
32			ImageList1: TImageList;
33			MenuItem1: TMenuItem;
34			MenuItem2: TMenuItem;
35			MenuItem3: TMenuItem;
36			MenuItem4: TMenuItem;
37			PopupMenu1: TPopupMenu;
38			Staff: TIBQuery;
39			Label7: TLabel;
40			Managers: TIBQuery;
41			Label2: TLabel;
42			Label3: TLabel;
43			Label4: TLabel;
44			Label5: TLabel;
45			Label6: TLabel;
46			Panel3: TPanel;
47			SaveBtn: TButton;
48			CancelBtn: TButton;
49			DataSource1: TDataSource;
50			DepartmentsBUDGET: TIBBCDField;
51			DepartmentsDEPARTMENT: TIBStringField;
52			DepartmentsDEPT_NO: TIBStringField;
53			DepartmentsHEAD_DEPT: TIBStringField;
54			DepartmentsLOCATION: TIBStringField;
55			DepartmentsMNGR_NO: TSmallintField;
56			DepartmentsPHONE_NO: TIBStringField;
57			IBDatabase1: TIBDatabase;
58			Departments: TIBDataSet;
59			IBTransaction1: TIBTransaction;
60			IBTreeView1: TIBTreeView;
61			Label1: TLabel;
62			Panel1: TPanel;
63			Panel2: TPanel;
64			Splitter1: TSplitter;
65			StaffDEPT_NO: TIBStringField;
66			StaffEMP_NO: TSmallintField;
67			StaffFIRST_NAME: TIBStringField;
68			StaffFULL_NAME: TIBStringField;
69			StaffHIRE_DATE: TDateTimeField;
70			StaffJOB_CODE: TIBStringField;
71			StaffJOB_COUNTRY: TIBStringField;
72			StaffJOB_GRADE: TSmallintField;
73			StaffLAST_NAME: TIBStringField;
74			StaffPHONE_EXT: TIBStringField;
75			StaffSALARY: TIBBCDField;
76			procedure AddChildExecute(Sender: TObject);
77			procedure AddFirstChildExecute(Sender: TObject);
78			procedure AddSiblingExecute(Sender: TObject);
79			procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
80			procedure CancelBtnClick(Sender: TObject);
81			procedure DeleteNodeExecute(Sender: TObject);
82			procedure DeleteNodeUpdate(Sender: TObject);
83			procedure DepartmentsAfterDelete(DataSet: TDataSet);
84			procedure DepartmentsAfterInsert(DataSet: TDataSet);
85			procedure DepartmentsAfterTransactionEnd(Sender: TObject);
86			procedure DepartmentsBUDGETChange(Sender: TField);
87			procedure DepartmentsBUDGETGetText(Sender: TField; var aText: string;
88			DisplayText: Boolean);
89			procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
90			procedure FormShow(Sender: TObject);
91			procedure IBTreeView1Addition(Sender: TObject; Node: TTreeNode);
92			procedure IBTreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
93			procedure IBTreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
94			State: TDragState; var Accept: Boolean);
95			procedure SaveBtnClick(Sender: TObject);
96			private
97			{ private declarations }
98			FDirty: boolean;
99			FClosing: boolean;
100			procedure Reopen(Data: PtrInt);
101			procedure SetNodeImage(Node: TTreeNode);
102			public
103			{ public declarations }
104			end;
105
106			var
107			Form1: TForm1;
108
109			implementation
110
111			{$R *.lfm}
112
113			uses IB;
114
115			{ TForm1 }
116
117			procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
118			begin
119			FClosing := true;
120			if IBTransaction1.Intransaction then
121			IBTransaction1.Commit;
122			end;
123
124			procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
125			begin
126			SaveBtn.Enabled := FDirty;
127			CancelBtn.Enabled := FDirty
128			end;
129
130			procedure TForm1.AddChildExecute(Sender: TObject);
131			begin
132			IBTreeView1.Selected.Expand(true);
133	tony	27	IBTreeView1.Selected := IBTreeView1.Items.AddChild(IBTreeView1.Selected,'');
134	tony	21	IBTreeView1.Selected.Expand(true);
135	tony	27	IBTreeView1.Selected.EditText;
136	tony	21	end;
137
138			procedure TForm1.AddFirstChildExecute(Sender: TObject);
139			begin
140			IBTreeView1.Selected.Expand(true);
141	tony	27	IBTreeView1.Selected := IBTreeView1.Items.AddChildFirst(IBTreeView1.Selected,'');
142	tony	21	IBTreeView1.Selected.Expand(true);
143	tony	27	IBTreeView1.Selected.EditText;
144	tony	21	end;
145
146			procedure TForm1.AddSiblingExecute(Sender: TObject);
147			begin
148	tony	27	IBTreeView1.Selected := IBTreeView1.Items.Add(IBTreeView1.Selected,'');
149			IBTreeView1.Selected.EditText;
150	tony	21	end;
151
152			procedure TForm1.CancelBtnClick(Sender: TObject);
153			begin
154			IBTransaction1.Rollback
155			end;
156
157			procedure TForm1.DeleteNodeExecute(Sender: TObject);
158			begin
159			if MessageDlg(Format('Do you want to delete the %s department?',[IBTreeview1.Selected.Text]),
160			mtConfirmation,[mbYes,mbNo],0) = mrYes then
161			TIBTreeNode(IBTreeview1.Selected).DeleteAll
162			end;
163
164			procedure TForm1.DeleteNodeUpdate(Sender: TObject);
165			begin
166			(Sender as TAction).Enabled := IBTreeView1.Selected <> nil
167			end;
168
169			procedure TForm1.DepartmentsAfterDelete(DataSet: TDataSet);
170			begin
171			FDirty := true
172			end;
173
174			procedure TForm1.DepartmentsAfterInsert(DataSet: TDataSet);
175			begin
176			FDirty := true;
177			DataSet.FieldByName('Department').AsString := 'Dept ' + DataSet.FieldByName('DEPT_NO').AsString
178			end;
179
180			procedure TForm1.DepartmentsAfterTransactionEnd(Sender: TObject);
181			begin
182			if not FClosing then
183			Application.QueueAsyncCall(@Reopen,0);
184			end;
185
186			procedure TForm1.DepartmentsBUDGETChange(Sender: TField);
187			begin
188			SetNodeImage(IBTreeView1.Selected)
189			end;
190
191			procedure TForm1.DepartmentsBUDGETGetText(Sender: TField; var aText: string;
192			DisplayText: Boolean);
193			begin
194			if DisplayText and not Sender.IsNull then
195			aText := FormatFloat('$#,##0.00',Sender.AsFloat)
196			else
197			aText := Sender.AsString
198			end;
199
200			procedure TForm1.FormShow(Sender: TObject);
201			begin
202			repeat
203			try
204			IBDatabase1.Connected := true;
205			except
206			on E:EIBClientError do
207			begin
208			Close;
209			Exit
210			end;
211			On E:Exception do
212			MessageDlg(E.Message,mtError,[mbOK],0);
213			end;
214			until IBDatabase1.Connected;
215			Reopen(0);
216			end;
217
218			procedure TForm1.IBTreeView1Addition(Sender: TObject; Node: TTreeNode);
219			begin
220			SetNodeImage(Node)
221			end;
222
223			procedure TForm1.IBTreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
224			var Node: TTreeNode;
225			tv: TTreeView;
226			begin
227			if Source = Sender then {Dragging within Tree View}
228			begin
229			tv := TTreeView(Sender);;
230			Node := tv.GetNodeAt(X,Y); {Drop Point}
231			if assigned(tv.Selected) and (tv.Selected <> Node) then
232			begin
233			if Node = nil then
234			tv.Selected.MoveTo(nil,naAdd) {Move to Top Level}
235			else
236			begin
237			if ssCtrl in GetKeyShiftState then
238			begin
239			Node.Expand(false);
240			tv.Selected.MoveTo(Node,naAddChildFirst)
241			end
242			else
243			tv.Selected.MoveTo(Node,naInsertBehind)
244			end;
245			end;
246			end;
247			end;
248
249			procedure TForm1.IBTreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
250			State: TDragState; var Accept: Boolean);
251			begin
252			Accept := Source = Sender
253			end;
254
255			procedure TForm1.SaveBtnClick(Sender: TObject);
256			begin
257			IBtransaction1.Commit
258			end;
259
260			procedure TForm1.Reopen(Data: PtrInt);
261			begin
262			FDirty := false;
263			IBTransaction1.StartTransaction;
264			Managers.Active := true;
265			Departments.Active := true;
266			Staff.Active := true;
267			end;
268
269			procedure TForm1.SetNodeImage(Node: TTreeNode);
270			begin
271			if Departments.FieldByName('Budget').AsFloat < 500000 then
272			Node.ImageIndex := 0
273			else
274			if Departments.FieldByName('Budget').AsFloat = 500000 then
275			Node.ImageIndex := 2
276			else
277			Node.ImageIndex := 1
278			end;
279
280			end.
281