1 { Copyright (C) 2005 Alexandru Alexandrov
2 Date: 11.06.2005
3
4 *****************************************************************************
5 See the file COPYING.modifiedLGPL.txt, included in this distribution,
6 for details about the license.
7 *****************************************************************************
8 }
9 { 2010-07-15 - New field type option (Data) Marcelo B. Paula
10 2010-10-30 - Persistent Name Edit... Marcelo B. Paula }
11
12 unit NewField;
13
14 {$mode ObjFPC}{$H+}
15
16 interface
17
18 uses
19 Classes, SysUtils, TypInfo, Math, DB,
20 // LCL
21 Forms, Dialogs, Graphics, Controls, ExtCtrls, StdCtrls, ButtonPanel,
22 // IdeIntf
23 ObjInspStrConsts, ComponentEditors, PropEdits, IDEWindowIntf;
24
25 type
26
27 { TNewFieldFrm }
28
29 TNewFieldFrm = class(TForm)
30 ButtonPanel1: TButtonPanel;
31 EditCompName: TEdit;
32 Label7: TLabel;
33 Label8: TLabel;
34 Label9: TLabel;
35 NoteLbl: TLabel;
36 GroupBox1: TGroupBox;
37 Label1: TLabel;
38 Label2: TLabel;
39 Label3: TLabel;
40 EditName: TEdit;
41 RadioGroup1: TRadioGroup;
42 SelectType: TComboBox;
43 EditSize: TEdit;
44 GroupBox2: TGroupBox;
45 Label4: TLabel;
46 Label5: TLabel;
47 Label6: TLabel;
48 Label10: TLabel;
49 SelectKeyFields: TComboBox;
50 SelectLookupKeys: TComboBox;
51 SelectResultField: TComboBox;
52 DataSetsCombo: TComboBox;
53 procedure DataSetsComboChange(Sender: TObject);
54 procedure EditCompNameChange(Sender: TObject);
55 procedure EditNameChange(Sender: TObject);
56 procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
57 procedure OKBtnClick(Sender: TObject);
58 procedure RadioGroup1Click(Sender: TObject);
59 procedure SelectKeyFieldsChange(Sender: TObject);
60 procedure SelectLookupKeysChange(Sender: TObject);
61 procedure SelectResultFieldChange(Sender: TObject);
62 procedure SelectTypeChange(Sender: TObject);
63 procedure FormCreate(Sender: TObject);
64 procedure UpdateLookupDatasets(Sender: TObject);
65 private
GetPersistentNamenull66 function GetPersistentName: string;
67 procedure SetPersistentName(const AValue: string);
CreateFieldNamenull68 function CreateFieldName(BaseName: String): String ;
69 private
70 LinkDataSet: TDataSet;
71 FDesigner: TComponentEditorDesigner;
72 AddLookupDatasetProc: TGetStrProc;
CreateFieldnull73 function CreateField(fType: TFieldType; FName: string): TField;
74 procedure SetButtons;
75 procedure UpdateResultFields;
76 procedure UpdateFieldsTypes;
GetLookupDatasetnull77 function GetLookupDataset: TDataset;
78 procedure AddLookupDataset(const s:ansistring);
79 property PersistentName: string read GetPersistentName write SetPersistentName;
SizeEnablenull80 function SizeEnable:Boolean;
81 public
82 constructor Create(AOwner: TComponent; ADataset: TDataset;
83 ADesigner: TComponentEditorDesigner); reintroduce;
84 destructor Destroy; override;
85 end ;
86
87 var
88 NewFieldFrm: TNewFieldFrm;
89
90 implementation
91
92 {$R *.lfm}
93
94 procedure SplitFieldsList(FldList: string; AList: TStrings);
95 const
96 SplitChars: Array[0..2] of Char = ('+',';',':');
97
FirstPosnull98 function FirstPos(AString: string): integer;
99 var i,j: integer;
100 begin
101 Result := -1;
102 for i := Low(SplitChars) to High(SplitChars) do begin
103 j := Pos(SplitChars[i], AString);
104 if (j <> 0) then begin
105 if Result < 1 then Result := j else
106 Result := Min(Result, j);
107 end;
108 end;
109 end;
110
111 var i: integer;
112 f,s: string;
113 begin
114 f := FldList;
115 i := FirstPos(f);
116 while (i>0)do begin
117 s := Copy(F, 1, i-1);
118 Delete(F, 1, i);
119 AList.Add(s);
120 i := FirstPos(F);
121 end;
122 if F <> '' then AList.Add(F);
123 end;
124
125 { TNewFieldFrm }
126
127 constructor TNewFieldFrm.Create(AOwner: TComponent; ADataset: TDataset;
128 ADesigner: TComponentEditorDesigner);
129 begin
130 LinkDataSet := ADataSet;
131 FDesigner := ADesigner;
132 inherited Create(AOwner);
133 AddLookupDatasetProc := @AddLookupDataset;
134 UpdateFieldsTypes;
135 UpdateLookupDatasets(Self);
136 RadioGroup1Click(nil);
137 end;
138
139 destructor TNewFieldFrm.Destroy;
140 begin
141 inherited Destroy;
142 end;
143
144 procedure TNewFieldFrm.FormCreate(Sender: TObject);
145 var i: integer;
146 begin
147 NoteLbl.Caption := fesNoFieldsNote;
148
149 Caption := fesFormCaption;
150 RadioGroup1.Caption := fesFieldType;
151 RadioGroup1.Items.Clear;
152 RadioGroup1.Items.Add(fesData);
153 RadioGroup1.Items.Add(fesCalculated);
154 RadioGroup1.Items.Add(fesLookup);
155 GroupBox1.Caption := fesFieldProps;
156 Label1.Caption := fesName;
157 Label2.Caption := fesType;
158 Label3.Caption := fesSize;
159 GroupBox2.Caption := fesLookupDef;
160 Label4.Caption := fesKeyfield;
161 Label10.Caption := fesDataset;
162 Label5.Caption := fesLookupKeys;
163 Label6.Caption := fesResultField;
164 Label7.Caption := fesPersistentCompName;
165 ButtonPanel1.OKButton.Caption := fesOkBtn;
166 ButtonPanel1.OKButton.OnClick:=@OKBtnClick;
167 ButtonPanel1.CancelButton.Caption := fesCancelBtn;
168
169 if Assigned(LinkDataSet) then begin
170 try
171 LinkDataset.FieldDefs.Update;
172 except
173 on E:Exception do begin
174 NoteLbl.visible := true;
175 //Panel1.Height := 100;
176 end;
177 end;
178 end;
179 for i := 0 to LinkDataSet.FieldDefs.Count - 1 do begin
180 SelectKeyFields.Items.Add(LinkDataSet.FieldDefs[i].Name);
181 end;
182
183 if LinkDataSet.FieldDefs.Count <> 0 then
184 RadioGroup1.ItemIndex := 1
185 else
186 RadioGroup1.ItemIndex := 0;
187
188 RadioGroup1Click(Nil);
189 IDEDialogLayoutList.ApplyLayout(Self);
190 end;
191
192 procedure TNewFieldFrm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
193 begin
194 IDEDialogLayoutList.SaveLayout(Self);
195 end;
196
TNewFieldFrm.CreateFieldnull197 function TNewFieldFrm.CreateField(fType: TFieldType; FName: string): TField;
198 begin
199 Result := Nil;
200 if DefaultFieldClasses[fType] <> Nil then begin
201 Result := DefaultFieldClasses[fType].Create(LinkDataSet.Owner);
202 Result.FieldName := fName;
203 Result.Name := PersistentName;
204 try
205 if (EditSize.Enabled) and (Trim(EditSize.Text)<> '') then
206 Result.Size := StrToInt(EditSize.Text);
207 except
208 end;
209 Result.DataSet := LinkDataSet;
210 end;
211 end;
212
213 procedure TNewFieldFrm.DataSetsComboChange(Sender: TObject);
214 begin
215 UpdateResultFields;
216 SetButtons;
217 end ;
218
219 procedure TNewFieldFrm.EditCompNameChange(Sender: TObject);
220 begin
221 SetButtons;
222 end;
223
224 procedure TNewFieldFrm.EditNameChange(Sender: TObject);
225 begin
226 if Trim(EditName.Text) <> '' then
227 PersistentName := CreateFieldName(LinkDataset.Name + EditName.Text)
228 else
229 PersistentName := '';
230 SetButtons;
231 end ;
232
233 procedure TNewFieldFrm.UpdateLookupDatasets(Sender: TObject);
234 var
235 sText: string;
236 begin
237 sText := SelectLookupKeys.Text;
238 DataSetsCombo.Clear;
239 FDesigner.PropertyEditorHook.GetComponentNames(GetTypeData(TDataset.ClassInfo),
240 AddLookupDatasetProc);
241 SelectLookupKeys.Text := sText;
242 end;
243
TNewFieldFrm.GetPersistentNamenull244 function TNewFieldFrm.GetPersistentName: string;
245 begin
246 Result := EditCompName.Text;
247 end;
248
249 procedure TNewFieldFrm.SetPersistentName(const AValue: string);
250 begin
251 EditCompName.Text := AValue;
252 end;
253
254 procedure TNewFieldFrm.OKBtnClick(Sender: TObject);
255
CheckNamenull256 function CheckName(FldName: string): string;
257 var i,j: integer;
258 begin
259 Result := FldName;
260 i := 0;
261 j := 0;
262 while (i < LinkDataSet.Fields.Count) do begin
263 if Result = LinkDataSet.Fields[i].FieldName then begin
264 inc(j);
265 Result := FldName + IntToStr(j);
266 end else Inc(i);
267 end;
268 end;
269
GetFieldDefnull270 function GetFieldDef(ADataset: TDataset; Name: string): TFieldDef;
271 var i: integer;
272 begin
273 Result := Nil;
274 for i := 0 to ADataset.FieldDefs.Count - 1 do
275 if AnsiCompareText(ADataset.FieldDefs[i].Name, Name) = 0 then begin
276 Result := ADataset.FieldDefs[i];
277 break;
278 end;
279 end;
280
281 var NewField: TField;
282 i: integer;
283 L: TStrings;
284 ADataset: TDataset;
285 sActive: boolean;
286 fldType: TFieldType;
287 begin
288 NewField := Nil;
289 sActive := LinkDataSet.Active;
290 LinkDataSet.Active := False;
291
292 try
293 case RadioGroup1.ItemIndex of
294 0: begin //Create data field
295 fldType := TFieldType(PtrUInt(SelectType.Items.Objects[SelectType.ItemIndex]));
296 NewField := CreateField(fldType, CheckName(EditName.Text));
297 if NewField<>nil then begin
298 NewField.Calculated := False;
299 NewField.FieldKind := fkData;
300
301 FDesigner.PropertyEditorHook.PersistentAdded(NewField, True);
302 FDesigner.Modified;
303 end else
304 ShowMessage(Format(fesFieldCanTBeC, [EditName.Text]));
305 end;
306 1: begin //Create calc field
307 fldType := TFieldType(PtrUInt(SelectType.Items.Objects[SelectType.ItemIndex]));
308 NewField := CreateField(fldType, CheckName(EditName.Text));
309 NewField.Calculated := True;
310 NewField.FieldKind := fkCalculated;
311
312 FDesigner.PropertyEditorHook.PersistentAdded(NewField, True);
313 FDesigner.Modified;
314 end;
315 else begin //Create lookup fields
316 L := TStringList.Create;
317 try
318 ADataset := GetLookupDataset;
319 SplitFieldsList(SelectResultField.Text, L);
320 for i := 0 to L.Count - 1 do begin
321 NewField := CreateField(GetFieldDef(ADataset, L[i]).DataType, CheckName(L[i]));
322 if NewField <> Nil then begin
323 if GetFieldDef(ADataset, L[i]).DataType = ftString then
324 NewField.Size := GetFieldDef(ADataset, L[i]).Size;
325 NewField.FieldKind := fkLookup;
326 NewField.KeyFields := SelectKeyFields.Text;
327 NewField.LookupDataSet := ADataset;
328 NewField.LookupResultField := L[i];
329 NewField.LookupKeyFields := SelectLookupKeys.Text;
330
331 FDesigner.PropertyEditorHook.PersistentAdded(NewField, True);
332 end else
333 ShowMessage(Format(fesFieldCanTBeC, [L[i]]));
334 end;
335 FDesigner.Modified;
336 finally
337 L.Free;
338 end;
339 end;
340 end;
341 except
342 if Assigned(NewField) then NewField.Free;
343 end;
344 if sActive then LinkDataSet.Active := True;
345 end;
346
347 procedure TNewFieldFrm.RadioGroup1Click(Sender: TObject);
348 begin
349 DisableAlign;
350 try
351 case RadioGroup1.ItemIndex of
352 0..1: begin //data,calculated field
353 GroupBox2.Visible := False;
354 GroupBox1.Visible := True;
355 end;
356 2: begin //lookup field
357 GroupBox2.Visible := True;
358 GroupBox1.Visible := False;
359 end;
360 end;
361 SetButtons;
362 finally
363 EnableAlign;
364 end;
365 end;
366
367 procedure TNewFieldFrm.SelectKeyFieldsChange(Sender: TObject);
368 begin
369 UpdateResultFields;
370 SetButtons;
371 end;
372
373 procedure TNewFieldFrm.SelectLookupKeysChange(Sender: TObject);
374 begin
375 SetButtons;
376 end;
377
378 procedure TNewFieldFrm.SelectResultFieldChange(Sender: TObject);
379 begin
380 SetButtons;
381 end;
382
383 procedure TNewFieldFrm.SelectTypeChange(Sender: TObject);
384 begin
385 UpdateResultFields;
386 SetButtons;
387 if Trim(EditSize.Text) <> '' then
388 EditSize.Text := '';
389 end;
390
391 procedure TNewFieldFrm.SetButtons;
392 begin
393 if SizeEnable then
394 begin
395 EditSize.Enabled := True;
396 EditSize.Color := clWindow;
397 end
398 else
399 begin
400 EditSize.Enabled := False;
401 EditSize.Color := clBtnFace;
402 end;
403 //
404 case RadioGroup1.ItemIndex of
405 0..1: ButtonPanel1.OKButton.Enabled := (Length(EditName.Text) > 0) And
406 (Length(PersistentName) > 0) And
407 (SelectType.ItemIndex > -1);
408 2: ButtonPanel1.OKButton.Enabled := (SelectKeyFields.Text <> '') And
409 (DataSetsCombo.ItemIndex > -1) And
410 (SelectLookupKeys.Text <> '') And
411 (SelectResultField.Text <> '');
412 end;
413 end;
414
415 procedure TNewFieldFrm.UpdateResultFields;
416 var i: integer;
417 ADataset: TDataset;
418 begin
419 SelectResultField.Clear;
420 SelectLookUpKeys.Clear;
421 if (DataSetsCombo.ItemIndex > -1) then begin
422 ADataset := GetLookupDataset;
423 if Assigned(ADataset) then begin
424 try
425 ADataset.FieldDefs.Update;
426 for i := 0 to ADataset.FieldDefs.Count - 1 do begin
427 SelectResultField.Items.Add(ADataset.FieldDefs[i].Name);
428 SelectLookUpKeys.Items.Add(ADataset.FieldDefs[i].Name);
429 end;
430 except
431 on E:Exception do begin
432 MessageDlg(fesNoFields+^M+fesCheckDSet+^M^M+Format(fesErrorMessage, [E.Message]), mtError, [mbOK], 0);
433 end;
434 end;
435 end;
436 end;
437 SelectLookUpKeys.Enabled := SelectLookUpKeys.Items.Count > 0;
438 SelectResultField.Enabled := SelectResultField.Items.Count > 0;
439 end;
440
441
442 procedure TNewFieldFrm.UpdateFieldsTypes;
443 var i: TFieldType;
444 begin
445 SelectType.Clear;
446 SelectType.Sorted := False;
447 for i := Low(Fieldtypenames) to High(Fieldtypenames) do
448 SelectType.Items.AddObject(Fieldtypenames[i], Tobject(PtrUInt(i)));
449 SelectType.Sorted := True;
450 end;
451
452
TNewFieldFrm.GetLookupDatasetnull453 function TNewFieldFrm.GetLookupDataset: TDataset;
454 begin
455 if GlobalDesignHook=Nil then
456 Result := Nil
457 else begin
458 Result := GlobalDesignHook.GetComponent( DataSetsCombo.Items[DataSetsCombo.ItemIndex] ) as TDataset;
459 if Not Result.InheritsFrom(TDataset) then Result := Nil;
460 end;
461 end;
462
463 procedure TNewFieldFrm.AddLookupDataset(const s: ansistring);
464 begin
465 if (AnsiCompareText(s, LinkDataSet.Name) <> 0) then
466 DataSetsCombo.Items.Add(s);
467 end;
468
SizeEnablenull469 function TNewFieldFrm.SizeEnable: Boolean;
470 begin
471 if SelectType.ItemIndex >= 0 then
472 case TFieldType(PtrUInt( SelectType.Items.Objects[SelectType.ItemIndex])) of
473 ftADT: Result := True;
474 ftArray: Result := True;
475 ftBCD: Result := True;
476 ftBlob: Result := True;
477 ftBytes: Result := True;
478 ftDataSet: Result := True;
479 ftFMTBcd: Result := True;
480 ftGraphic: Result := True;
481 ftMemo: Result := True;
482 ftString: Result := True;
483 ftWideString: Result := True;
484 ftVarBytes: Result := True;
485 ftVariant: Result := True;
486 else
487 Result := False
488 end
489 else
490 Result := False;
491 end;
492
TNewFieldFrm.CreateFieldNamenull493 function TNewFieldFrm.CreateFieldName(BaseName: String): String ;
494 var
495 i: integer;
496 ExistingComponent, OwnerComponent: TComponent;
497 begin
498 Result:=BaseName;
499 OwnerComponent := FDesigner.LookupRoot;
500 if (OwnerComponent=nil) or (Result='') then exit;
501 i:=1;
502 repeat
503 ExistingComponent := OwnerComponent.FindComponent(Result);
504 if ExistingComponent<>nil then
505 begin
506 if (BaseName[Length(BaseName)] in ['0'..'9']) then
507 Result := BaseName+'_'+IntToStr(i)
508 else
509 Result := BaseName+IntToStr(i);
510 inc(i);
511 end ;
512 until ExistingComponent=nil;
513 end;
514
515
516 end.
517