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, 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
    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.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:	311
Committed:	Mon Aug 24 09:32:58 2020 UTC (4 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	7819 byte(s)
Log Message:	Fixes merged
#	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			StdCtrls, DbCtrls, ActnList, Menus, db, 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	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			TIBTreeNode(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