1 {
2 TDBDateTimePicker control for Lazarus
3 - - - - - - - - - - - - - - - - - - - -
4 Author: Zoran Vučenović, January and February 2010
5 Зоран Вученовић, јануар и фебруар 2010.
6
7 This unit is part of DateTimeCtrls package for Lazarus.
8 TDBDateTimePicker is data-aware version of TDateTimePicker control.
9
10 -----------------------------------------------------------
11 LICENCE
12 - - - -
13 Modified LGPL -- see the file COPYING.modifiedLGPL.
14
15 -----------------------------------------------------------
16 NO WARRANTY
17 - - - - - -
18 There is no warranty whatsoever.
19
20 -----------------------------------------------------------
21 BEST REGARDS TO LAZARUS COMMUNITY!
22 - - - - - - - - - - - - - - - - - -
23 I do hope this control will be useful.
24 }
25 unit DBDateTimePicker;
26
27 {$mode objfpc}{$H+}
28
29 interface
30
31 uses
32 Classes, SysUtils, DateTimePicker, db, DBCtrls, LMessages;
33
34 type
35
36 { TDBDateTimePicker }
37
38 TDBDateTimePicker = class(TCustomDateTimePicker)
39 private
40 { Private declarations }
41 FDataLink: TFieldDataLink;
42 FReadOnly: Boolean;
43 FDataChangeCount: Integer;
44 FChangingCount: Integer;
GetDataFieldnull45 function GetDataField: string;
GetDataSourcenull46 function GetDataSource: TDataSource;
47 procedure SetDataField(const AValue: string);
48 procedure SetDataSource(const AValue: TDataSource);
49 procedure DataChange(Sender: TObject);
50 procedure SetReadOnly(const AValue: Boolean);
51 procedure UpdateData(Sender: TObject);
52 procedure ActiveChange(Sender: TObject);
GetFieldnull53 function GetField: TField;
54 procedure CheckField;
55 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK;
56 protected
57 { Protected declarations }
58 procedure Change; override;
59 procedure ConfirmChanges; override;
60 procedure UndoChanges; override;
61 public
62 { Public declarations }
63 constructor Create(AOwner: TComponent); override;
64 destructor Destroy; override;
65 property Field: TField read GetField;
66 property CalendarWrapperClass;
67 property DroppedDown;
68 published
69 { Published declarations }
70 property DataField: string read GetDataField write SetDataField;
71 property DataSource: TDataSource read GetDataSource write SetDataSource;
72 property ReadOnly: Boolean read FReadOnly write SetReadOnly;
73
74 property ArrowShape;
75 property ShowCheckBox;
76 property Checked;
77 property CenturyFrom;
78 property DateDisplayOrder;
79 property MaxDate;
80 property MinDate;
81 property AutoSize;
82 property Font;
83 property ParentFont;
84 property TabOrder;
85 property TabStop;
86 property BorderStyle;
87 property BorderSpacing;
88 property Enabled;
89 property Color;
90 property ParentColor;
91 property DateSeparator;
92 property TrailingSeparator;
93 property TextForNullDate;
94 property LeadingZeros;
95 property ShowHint;
96 property ParentShowHint;
97 property Align;
98 property Anchors;
99 property Constraints;
100 property Cursor;
101 property PopupMenu;
102 property Visible;
103 property NullInputAllowed;
104 property Kind;
105 property TimeSeparator;
106 property TimeFormat;
107 property TimeDisplay;
108 property DateMode;
109 property UseDefaultSeparators;
110 property Cascade;
111 property AutoButtonSize;
112 property AutoAdvance;
113 property HideDateTimeParts;
114 property BiDiMode;
115 property ParentBiDiMode;
116 property MonthNames;
117 property ShowMonthNames;
118 property CalAlignment;
119 //events:
120 property OnChange;
121 property OnCheckBoxChange;
122 property OnDropDown;
123 property OnCloseUp;
124 property OnChangeBounds;
125 property OnClick;
126 property OnContextPopup;
127 property OnDblClick;
128 property OnEditingDone;
129 property OnEnter;
130 property OnExit;
131 property OnKeyDown;
132 property OnKeyPress;
133 property OnKeyUp;
134 property OnMouseDown;
135 property OnMouseEnter;
136 property OnMouseLeave;
137 property OnMouseMove;
138 property OnMouseUp;
139 property OnMouseWheel;
140 property OnMouseWheelDown;
141 property OnMouseWheelUp;
142 property OnResize;
143 property OnUTF8KeyPress;
144 end;
145
146 implementation
147
148 { TDBDateTimePicker }
149
GetDataFieldnull150 function TDBDateTimePicker.GetDataField: string;
151 begin
152 Result := FDataLink.FieldName;
153 end;
154
GetDataSourcenull155 function TDBDateTimePicker.GetDataSource: TDataSource;
156 begin
157 Result := FDataLink.DataSource;
158 end;
159
160 procedure TDBDateTimePicker.SetDataField(const AValue: string);
161 begin
162 FDataLink.FieldName := AValue;
163 CheckField;
164 end;
165
166 procedure TDBDateTimePicker.SetDataSource(const AValue: TDataSource);
167 begin
168 ChangeDataSource(Self, FDataLink, AValue);
169 CheckField;
170 end;
171
172 procedure TDBDateTimePicker.DataChange(Sender: TObject);
173 begin
174 if (FChangingCount = 0) then begin
175 Inc(FDataChangeCount);
176 try
177 if Assigned(FDataLink.Field) and not FDataLink.Field.IsNull then begin
178 // Using the SetTheDateJumpMinMax procedure, instead of property
179 SetDateTimeJumpMinMax(FDataLink.Field.AsDateTime); // assignment allows
180 // this control to display dates from database whose value falls
181 // outside of MinDate and MaxDate interval.
182 // Note that user still cannot enter such values in the control.
183 end else
184 DateTime := NullDate;
185
186 finally
187 Dec(FDataChangeCount);
188 end;
189 end;
190 end;
191
192 procedure TDBDateTimePicker.SetReadOnly(const AValue: Boolean);
193 begin
194 if FReadOnly <> AValue then begin
195 FReadOnly := AValue;
196 CheckField;
197 end;
198 end;
199
200 procedure TDBDateTimePicker.UpdateData(Sender: TObject);
201 begin
202 if Assigned(FDataLink.Field) then begin
203 if DateIsNull then
204 FDataLink.Field.AsVariant := Null
205 else
206 FDataLink.Field.AsDateTime := DateTime;
207 end;
208 end;
209
210 procedure TDBDateTimePicker.ActiveChange(Sender: TObject);
211 begin
212 CheckField;
213 end;
214
GetFieldnull215 function TDBDateTimePicker.GetField: TField;
216 begin
217 Result := FDataLink.Field;
218 end;
219
220 procedure TDBDateTimePicker.CheckField;
221 begin
222 if (FDataLink.Active) and Assigned(FDataLink.Field) then
223 inherited ReadOnly := FReadOnly or (not FDataLink.CanModify)
224 else begin
225 inherited ReadOnly := True;
226 DateTime := NullDate;
227 end;
228 end;
229
230 procedure TDBDateTimePicker.CMGetDataLink(var Message: TLMessage);
231 begin
232 Message.Result := PtrUInt(FDataLink);
233 end;
234
235 procedure TDBDateTimePicker.Change;
236 begin
237 if (FDataChangeCount <= 0) and Assigned(FDataLink) then begin
238 Inc(FChangingCount);
239 try
240 if FDataLink.Edit then begin
241 FDataLink.Modified;
242 inherited Change; // calls OnChange event handler
243 end else
244 FDataLink.Reset; // reverts user changes
245 finally
246 Dec(FChangingCount);
247 end;
248 end;
249 end;
250
251 procedure TDBDateTimePicker.ConfirmChanges;
252 begin
253 inherited ConfirmChanges;
254
255 if Assigned(FDataLink) then
256 try
257 FDataLink.UpdateRecord;
258 except
259 SetFocus;
260 raise;
261 end;
262
263 end;
264
265 procedure TDBDateTimePicker.UndoChanges;
266 begin
267 FDataLink.Reset;
268
269 inherited UndoChanges;
270 end;
271
272 constructor TDBDateTimePicker.Create(AOwner: TComponent);
273 begin
274 inherited Create(AOwner);
275
276 FDataChangeCount := 0;
277 FChangingCount := 0;
278 FDataLink := TFieldDataLink.Create;
279 FDataLink.Control := Self;
280 DateTime := NullDate;
281 FDataLink.OnActiveChange := @ActiveChange;
282 FDataLink.OnDataChange := @DataChange;
283 FDataLink.OnUpdateData := @UpdateData;
284
285 CheckField;
286 end;
287
288 destructor TDBDateTimePicker.Destroy;
289 begin
290 FDataLink.OnUpdateData := nil;
291 FDataLink.OnDataChange := nil;
292 FDataLink.OnActiveChange := nil;
293 FreeAndNil(FDataLink);
294
295 inherited Destroy;
296 end;
297
298 end.
299