examples/ibtable/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,
  DBGrids, StdCtrls, db, IBDatabase, IBTable, IBCustomDataSet, IBDynamicGrid,
  IB;

type

  { TForm1 }

  TForm1 = class(TForm)
    CheckBox1: TCheckBox;
    Datasource1: TDataSource;
    DataSource2: TDataSource;
    EmployeesFULL_NAME: TIBStringField;
    IBDatabase1: TIBDatabase;
    IBDynamicGrid1: TIBDynamicGrid;
    Employees: TIBTable;
    EmployeesDEPT_NO: TIBStringField;
    EmployeesEMP_NO: TSmallintField;
    EmployeesFIRST_NAME: TIBStringField;
    EmployeesHIRE_DATE: TDateTimeField;
    EmployeesJOB_CODE: TIBStringField;
    EmployeesJOB_COUNTRY: TIBStringField;
    EmployeesJOB_GRADE: TSmallintField;
    EmployeesLAST_NAME: TIBStringField;
    EmployeesPHONE_EXT: TIBStringField;
    EmployeesSALARY: TIBBCDField;
    Depts: TIBTable;
    DeptsBUDGET: TIBBCDField;
    DeptsDEPARTMENT: TIBStringField;
    DeptsDEPT_NO: TIBStringField;
    DeptsHEAD_DEPT: TIBStringField;
    DeptsLOCATION: TIBStringField;
    DeptsMNGR_NO: TSmallintField;
    DeptsPHONE_NO: TIBStringField;
    IBDynamicGrid2: TIBDynamicGrid;
    IBTransaction1: TIBTransaction;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel4: TPanel;
    Splitter1: TSplitter;
    procedure CheckBox1Change(Sender: TObject);
    procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
      DisplayText: Boolean);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure DeptsAfterOpen(DataSet: TDataSet);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

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;
end;

procedure TForm1.EmployeesSALARYGetText(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.CheckBox1Change(Sender: TObject);
begin
  if (Sender as TCheckbox).Checked then
    Employees.Filter := 'Salary < 100000'
  else
    Employees.Filter := '';
end;

procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
begin
  Depts.Active := true;
end;

procedure TForm1.DeptsAfterOpen(DataSet: TDataSet);
begin
  Employees.Active := true;
end;

end.

Revision:	312
Committed:	Tue Aug 25 15:40:58 2020 UTC (7 months, 3 weeks ago) by tony
File size:	3531 byte(s)
Log Message:	Fixes Merged
Line	File contents
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	DBGrids, StdCtrls, db, IBDatabase, IBTable, IBCustomDataSet, IBDynamicGrid,
36	IB;
37
38	type
39
40	{ TForm1 }
41
42	TForm1 = class(TForm)
43	CheckBox1: TCheckBox;
44	Datasource1: TDataSource;
45	DataSource2: TDataSource;
46	EmployeesFULL_NAME: TIBStringField;
47	IBDatabase1: TIBDatabase;
48	IBDynamicGrid1: TIBDynamicGrid;
49	Employees: TIBTable;
50	EmployeesDEPT_NO: TIBStringField;
51	EmployeesEMP_NO: TSmallintField;
52	EmployeesFIRST_NAME: TIBStringField;
53	EmployeesHIRE_DATE: TDateTimeField;
54	EmployeesJOB_CODE: TIBStringField;
55	EmployeesJOB_COUNTRY: TIBStringField;
56	EmployeesJOB_GRADE: TSmallintField;
57	EmployeesLAST_NAME: TIBStringField;
58	EmployeesPHONE_EXT: TIBStringField;
59	EmployeesSALARY: TIBBCDField;
60	Depts: TIBTable;
61	DeptsBUDGET: TIBBCDField;
62	DeptsDEPARTMENT: TIBStringField;
63	DeptsDEPT_NO: TIBStringField;
64	DeptsHEAD_DEPT: TIBStringField;
65	DeptsLOCATION: TIBStringField;
66	DeptsMNGR_NO: TSmallintField;
67	DeptsPHONE_NO: TIBStringField;
68	IBDynamicGrid2: TIBDynamicGrid;
69	IBTransaction1: TIBTransaction;
70	Panel1: TPanel;
71	Panel2: TPanel;
72	Panel3: TPanel;
73	Panel4: TPanel;
74	Splitter1: TSplitter;
75	procedure CheckBox1Change(Sender: TObject);
76	procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
77	DisplayText: Boolean);
78	procedure FormShow(Sender: TObject);
79	procedure IBDatabase1AfterConnect(Sender: TObject);
80	procedure DeptsAfterOpen(DataSet: TDataSet);
81	private
82	{ private declarations }
83	public
84	{ public declarations }
85	end;
86
87	var
88	Form1: TForm1;
89
90	implementation
91
92	{$R *.lfm}
93
94	{ TForm1 }
95
96	procedure TForm1.FormShow(Sender: TObject);
97	begin
98	repeat
99	try
100	IBDatabase1.Connected := true;
101	except
102	on E:EIBClientError do
103	begin
104	Close;
105	Exit
106	end;
107	On E:Exception do
108	MessageDlg(E.Message,mtError,[mbOK],0);
109	end;
110	until IBDatabase1.Connected;
111	end;
112
113	procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
114	DisplayText: Boolean);
115	begin
116	if DisplayText and not Sender.IsNull then
117	aText := FormatFloat('$#,##0.00',Sender.AsFloat)
118	else
119	aText := Sender.AsString;
120	end;
121
122	procedure TForm1.CheckBox1Change(Sender: TObject);
123	begin
124	if (Sender as TCheckbox).Checked then
125	Employees.Filter := 'Salary < 100000'
126	else
127	Employees.Filter := '';
128	end;
129
130	procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
131	begin
132	Depts.Active := true;
133	end;
134
135	procedure TForm1.DeptsAfterOpen(DataSet: TDataSet);
136	begin
137	Employees.Active := true;
138	end;
139
140	end.
141