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 DepartmentsBeforeScroll(DataSet: TDataSet);
    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.Items.AddChild(IBTreeView1.Selected,'');
  IBTreeView1.Selected.Expand(true);
end;

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

procedure TForm1.AddSiblingExecute(Sender: TObject);
begin
  IBTreeView1.Items.Add(IBTreeView1.Selected,'');
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.DepartmentsBeforeScroll(DataSet: TDataSet);
begin
  with DataSet do
    try
      if State in [dsInsert,dsEdit] then Post
    except on E: Exception do
      begin
        Cancel;
        MessageDlg(E.Message,mtError,[mbOK],0)
      end
    end;
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:	21
Committed:	Thu Feb 26 10:33:34 2015 UTC (9 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	7721 byte(s)
Log Message:	Committing updates for Release R1-2-0
#	Content
1	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 DepartmentsBeforeScroll(DataSet: TDataSet);
87	procedure DepartmentsBUDGETChange(Sender: TField);
88	procedure DepartmentsBUDGETGetText(Sender: TField; var aText: string;
89	DisplayText: Boolean);
90	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
91	procedure FormShow(Sender: TObject);
92	procedure IBTreeView1Addition(Sender: TObject; Node: TTreeNode);
93	procedure IBTreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
94	procedure IBTreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
95	State: TDragState; var Accept: Boolean);
96	procedure SaveBtnClick(Sender: TObject);
97	private
98	{ private declarations }
99	FDirty: boolean;
100	FClosing: boolean;
101	procedure Reopen(Data: PtrInt);
102	procedure SetNodeImage(Node: TTreeNode);
103	public
104	{ public declarations }
105	end;
106
107	var
108	Form1: TForm1;
109
110	implementation
111
112	{$R *.lfm}
113
114	uses IB;
115
116	{ TForm1 }
117
118	procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
119	begin
120	FClosing := true;
121	if IBTransaction1.Intransaction then
122	IBTransaction1.Commit;
123	end;
124
125	procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
126	begin
127	SaveBtn.Enabled := FDirty;
128	CancelBtn.Enabled := FDirty
129	end;
130
131	procedure TForm1.AddChildExecute(Sender: TObject);
132	begin
133	IBTreeView1.Selected.Expand(true);
134	IBTreeView1.Items.AddChild(IBTreeView1.Selected,'');
135	IBTreeView1.Selected.Expand(true);
136	end;
137
138	procedure TForm1.AddFirstChildExecute(Sender: TObject);
139	begin
140	IBTreeView1.Selected.Expand(true);
141	IBTreeView1.Items.AddChildFirst(IBTreeView1.Selected,'');
142	IBTreeView1.Selected.Expand(true);
143	end;
144
145	procedure TForm1.AddSiblingExecute(Sender: TObject);
146	begin
147	IBTreeView1.Items.Add(IBTreeView1.Selected,'');
148	end;
149
150	procedure TForm1.CancelBtnClick(Sender: TObject);
151	begin
152	IBTransaction1.Rollback
153	end;
154
155	procedure TForm1.DeleteNodeExecute(Sender: TObject);
156	begin
157	if MessageDlg(Format('Do you want to delete the %s department?',[IBTreeview1.Selected.Text]),
158	mtConfirmation,[mbYes,mbNo],0) = mrYes then
159	TIBTreeNode(IBTreeview1.Selected).DeleteAll
160	end;
161
162	procedure TForm1.DeleteNodeUpdate(Sender: TObject);
163	begin
164	(Sender as TAction).Enabled := IBTreeView1.Selected <> nil
165	end;
166
167	procedure TForm1.DepartmentsAfterDelete(DataSet: TDataSet);
168	begin
169	FDirty := true
170	end;
171
172	procedure TForm1.DepartmentsAfterInsert(DataSet: TDataSet);
173	begin
174	FDirty := true;
175	DataSet.FieldByName('Department').AsString := 'Dept ' + DataSet.FieldByName('DEPT_NO').AsString
176	end;
177
178	procedure TForm1.DepartmentsAfterTransactionEnd(Sender: TObject);
179	begin
180	if not FClosing then
181	Application.QueueAsyncCall(@Reopen,0);
182	end;
183
184	procedure TForm1.DepartmentsBeforeScroll(DataSet: TDataSet);
185	begin
186	with DataSet do
187	try
188	if State in [dsInsert,dsEdit] then Post
189	except on E: Exception do
190	begin
191	Cancel;
192	MessageDlg(E.Message,mtError,[mbOK],0)
193	end
194	end;
195	end;
196
197	procedure TForm1.DepartmentsBUDGETChange(Sender: TField);
198	begin
199	SetNodeImage(IBTreeView1.Selected)
200	end;
201
202	procedure TForm1.DepartmentsBUDGETGetText(Sender: TField; var aText: string;
203	DisplayText: Boolean);
204	begin
205	if DisplayText and not Sender.IsNull then
206	aText := FormatFloat('$#,##0.00',Sender.AsFloat)
207	else
208	aText := Sender.AsString
209	end;
210
211	procedure TForm1.FormShow(Sender: TObject);
212	begin
213	repeat
214	try
215	IBDatabase1.Connected := true;
216	except
217	on E:EIBClientError do
218	begin
219	Close;
220	Exit
221	end;
222	On E:Exception do
223	MessageDlg(E.Message,mtError,[mbOK],0);
224	end;
225	until IBDatabase1.Connected;
226	Reopen(0);
227	end;
228
229	procedure TForm1.IBTreeView1Addition(Sender: TObject; Node: TTreeNode);
230	begin
231	SetNodeImage(Node)
232	end;
233
234	procedure TForm1.IBTreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
235	var Node: TTreeNode;
236	tv: TTreeView;
237	begin
238	if Source = Sender then {Dragging within Tree View}
239	begin
240	tv := TTreeView(Sender);;
241	Node := tv.GetNodeAt(X,Y); {Drop Point}
242	if assigned(tv.Selected) and (tv.Selected <> Node) then
243	begin
244	if Node = nil then
245	tv.Selected.MoveTo(nil,naAdd) {Move to Top Level}
246	else
247	begin
248	if ssCtrl in GetKeyShiftState then
249	begin
250	Node.Expand(false);
251	tv.Selected.MoveTo(Node,naAddChildFirst)
252	end
253	else
254	tv.Selected.MoveTo(Node,naInsertBehind)
255	end;
256	end;
257	end;
258	end;
259
260	procedure TForm1.IBTreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
261	State: TDragState; var Accept: Boolean);
262	begin
263	Accept := Source = Sender
264	end;
265
266	procedure TForm1.SaveBtnClick(Sender: TObject);
267	begin
268	IBtransaction1.Commit
269	end;
270
271	procedure TForm1.Reopen(Data: PtrInt);
272	begin
273	FDirty := false;
274	IBTransaction1.StartTransaction;
275	Managers.Active := true;
276	Departments.Active := true;
277	Staff.Active := true;
278	end;
279
280	procedure TForm1.SetNodeImage(Node: TTreeNode);
281	begin
282	if Departments.FieldByName('Budget').AsFloat < 500000 then
283	Node.ImageIndex := 0
284	else
285	if Departments.FieldByName('Budget').AsFloat = 500000 then
286	Node.ImageIndex := 2
287	else
288	Node.ImageIndex := 1
289	end;
290
291	end.
292