examples/ibtreeview/Unit1.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*) 
            
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  StdCtrls, DbCtrls, ActnList, Menus, db, DBTreeView, 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: TIBLargeIntField;
    DepartmentsIMAGEINDEX: TIBIntegerField;
    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 DepartmentsBUDGETGetText(Sender: TField; var aText: string;
      DisplayText: Boolean);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormShow(Sender: TObject);
    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);
  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
    TDBTreeNode(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.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.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;

end.

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