ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/ibtable/Unit1.pas
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