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:	380
Committed:	Mon Jan 10 10:13:17 2022 UTC (2 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	7831 byte(s)
Log Message:	propset for eol-style
#	User	Rev	Content
1	tony	143	(*
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	tony	21	unit Unit1;
28
29			{$mode objfpc}{$H+}
30
31			interface
32
33			uses
34			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
35	tony	315	StdCtrls, DbCtrls, ActnList, Menus, db, DBTreeView, IBTreeView, IBDatabase,
36	tony	21	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	tony	311	DepartmentsCHILDCOUNT: TIBLargeIntField;
56	tony	143	DepartmentsIMAGEINDEX: TIBIntegerField;
57	tony	21	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	tony	27	IBTreeView1.Selected := IBTreeView1.Items.AddChild(IBTreeView1.Selected,'');
158	tony	21	IBTreeView1.Selected.Expand(true);
159	tony	27	IBTreeView1.Selected.EditText;
160	tony	21	end;
161
162			procedure TForm1.AddFirstChildExecute(Sender: TObject);
163			begin
164			IBTreeView1.Selected.Expand(true);
165	tony	27	IBTreeView1.Selected := IBTreeView1.Items.AddChildFirst(IBTreeView1.Selected,'');
166	tony	21	IBTreeView1.Selected.Expand(true);
167	tony	27	IBTreeView1.Selected.EditText;
168	tony	21	end;
169
170			procedure TForm1.AddSiblingExecute(Sender: TObject);
171			begin
172	tony	27	IBTreeView1.Selected := IBTreeView1.Items.Add(IBTreeView1.Selected,'');
173			IBTreeView1.Selected.EditText;
174	tony	21	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	tony	315	TDBTreeNode(IBTreeview1.Selected).DeleteAll
186	tony	21	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