source: trunk/Sibyl/SPCC/DBBASE.PAS

Last change on this file was 7, checked in by RBRi, 19 years ago

+ sibyl staff
  • Property svn:eol-style set to native
File size: 215.9 KB
RevLine 
[7]1
2{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3 º º
4 º Sibyl Portable Component Classes º
5 º º
6 º Copyright (C) 1995,97 SpeedSoft Germany, All rights reserved. º
7 º º
8 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ}
9
10Unit DBBase;
11
12
13Interface
14
15
16Uses Dos,SysUtils,Classes,Forms,Dialogs,DbLayer;
17
18Type
19 TField=Class;
20 TDataSet=Class;
21 TDataSource=Class;
22
23 ESQLError=Class(Exception);
24
25 TDataChange=(dePositionChanged,deDataBaseChanged,deTableNameChanged);
26
27 TDataChangeEvent=Procedure(Sender:TObject;event:TDataChange) Of Object;
28
29
30 TDataLink=Class(TComponent)
31 Private
32 FDataSource:TDataSource;
33 FOnDataChange:TDataChangeEvent;
34 Procedure SetDataSource(NewValue:TDataSource);
35 Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
36 Procedure DataChange(event:TDataChange);
37 Protected
38 Procedure SetupComponent;Override;
39 Public
40 Destructor Destroy;Override;
41 Property DataSource:TDataSource Read FDataSource Write SetDataSource;
42 Property OnDataChange:TDataChangeEvent Read FOnDataChange Write FOnDataChange;
43 End;
44
45
46 TTableDataLink=Class(TDataLink)
47 Private
48 Function GetColRowField(Col,Row:LongInt):TField;
49 Function GetNameRowField(Name:String;Row:LongInt):TField;
50 Function GetFieldCount:LongInt;
51 Function GetFieldName(Index:LongInt):String;
52 Protected
53 Procedure SetupComponent;Override;
54 Public
55 Property Fields[Col,Row:LongInt]:TField Read GetColRowField;
56 Property FieldsFromColumnName[Col:String;Row:LongInt]:TField Read GetNameRowField;
57 Property FieldCount:LongInt Read GetFieldCount;
58 Property FieldNames[Index:LongInt]:String read GetFieldName;
59 End;
60
61
62 TFieldDataLink=Class(TDataLink)
63 Private
64 FFieldName:PString;
65 Procedure SetFieldName(Const NewValue:String);
66 Function GetFieldName:String;
67 Function GetField:TField;
68 Protected
69 Procedure SetupComponent;Override;
70 Public
71 Destructor Destroy;Override;
72 Property FieldName:String Read GetFieldName Write SetFieldName;
73 Property field:TField Read GetField;
74 End;
75
76
77 TDataSource=Class(TComponent)
78 Private
79 FDataSet:TDataSet;
80 FOnDataChange:TDataChangeEvent;
81 Procedure SetDataSet(NewValue:TDataSet);
82 Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
83 Protected
84 Procedure SetupComponent;Override;
85 Procedure DataChange(event:TDataChange);Virtual;
86 Public
87 Destructor Destroy;Override;
88 Published
89 Property DataSet:TDataSet Read FDataSet Write SetDataSet;
90 Property OnDataChange:TDataChangeEvent Read FOnDataChange Write FOnDataChange;
91 End;
92
93
94 TFieldType=(ftUnknown,ftString,ftSmallInt,ftInteger,ftWord,ftBoolean,
95 ftFloat,ftCurrency,ftBCD,ftDate,ftTime,ftDateTime,ftBytes,
96 ftVarBytes,ftAutoInc,ftBlob,ftMemo,ftGraphic,ftFmtMemo,
97 ftTypedBinary,ftOLE);
98
99 EDataBaseError=Class(Exception);
100
101 TFieldDefs=Class;
102 TFieldDef=Class;
103
104 TOnFieldChange=Procedure(Sender:TField) Of Object;
105
106 TField=Class
107 Private
108 FSize:Longword; //store size of datatype (floatfield!)
109 FValue:Pointer;
110 FValueLen:LongWord;
111 FDataType:TFieldType;
112 FDataSet:TDataSet;
113 FFieldDef:TFieldDef;
114 FRequired:Boolean;
115 FRow:LongInt;
116 FCol:LongInt;
117 FReadOnly:Boolean;
118 FOnChange:TOnFieldChange;
119 Procedure FreeMemory;
120 Procedure GetMemory(Size:Longint);
121 Function GetFieldName:String;
122 Function GetIsNull:Boolean;
123 Procedure SetNewValue(Var NewValue;NewLen:LongInt);
124 Function GetAsVariant:Variant;Virtual;
125 Procedure SetAsVariant(NewValue:Variant);Virtual;
126 Function GetIsIndexField:Boolean;
127 Function GetCanModify:Boolean;
128 Function GetReadOnly:Boolean;
129 Protected
130 Procedure SetAsValue(Var Value;Len:LongInt);Virtual;
131 Function GetAsString:String;Virtual;
132 Procedure SetAsString(Const NewValue:String);Virtual;
133 Function GetAsAnsiString:AnsiString;Virtual;
134 Procedure SetAsAnsiString(NewValue:AnsiString);Virtual;
135 Function GetAsBoolean:Boolean;Virtual;
136 Procedure SetAsBoolean(NewValue:Boolean);Virtual;
137 Function GetAsDateTime:TDateTime;Virtual;
138 Procedure SetAsDateTime(NewValue:TDateTime);Virtual;
139 Function GetAsFloat:Extended;Virtual;
140 Procedure SetAsFloat(Const NewValue:Extended);Virtual;
141 Function GetAsInteger:LongInt;Virtual;
142 Procedure SetAsInteger(NewValue:LongInt);Virtual;
143 Procedure AccessError(Const TypeName:String);Virtual;
144 Procedure CheckInactive;
145 Public
146 Destructor Destroy;Override;
147 Procedure Clear;Virtual;
148 Procedure Assign(Field:TField);
149 Procedure SetData(Buffer:Pointer);
150 Property IsNull:Boolean Read GetIsNull;
151 Property ValueLen:LongWord Read FValueLen;
152 Property DataType:TFieldType Read FDataType;
153 Property Required:Boolean Read FRequired Write FRequired;
154 Property Row:LongInt read FRow write FRow;
155 Property Value:Variant read GetAsVariant write SetAsVariant;
156 Property IsIndexField:Boolean read GetIsIndexField;
157 Property CanModify:Boolean read GetCanModify;
158 Property DataSet:TDataSet read FDataSet;
159 Property DataSize:LongWord read FValueLen;
160 Property ReadOnly:boolean read GetReadOnly write FReadOnly;
161 Property Index:LongInt read FCol;
162 Published
163 Property FieldName:String Read GetFieldName;
164 Property AsString:String Read GetAsString Write SetAsString;
165 Property AsAnsiString:AnsiString Read GetAsAnsiString Write SetAsAnsiString;
166 Property AsBoolean:Boolean Read GetAsBoolean Write SetAsBoolean;
167 Property AsDateTime:TDateTime Read GetAsDateTime Write SetAsDateTime;
168 Property AsFloat:Extended Read GetAsFloat Write SetAsFloat;
169 Property AsInteger:LongInt Read GetAsInteger Write SetAsInteger;
170 Property OnChange:TOnFieldChange read FOnChange write FOnChange;
171 End;
172 TFieldClass=Class Of TField;
173
174
175 TStringField=Class(TField)
176 Protected
177 Function GetAsString:String;Override;
178 Procedure SetAsString(Const NewValue:String);Override;
179 Function GetAsAnsiString:AnsiString;Override;
180 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
181 Function GetAsBoolean:Boolean;Override;
182 Procedure SetAsBoolean(NewValue:Boolean);Override;
183 Function GetAsDateTime:TDateTime;Override;
184 Function GetAsFloat:Extended;Override;
185 Procedure SetAsFloat(Const NewValue:Extended);Override;
186 Function GetAsInteger:LongInt;Override;
187 Procedure SetAsInteger(NewValue:LongInt);Override;
188 Function GetAsVariant:Variant;Override;
189 Procedure SetAsVariant(NewValue:Variant);Override;
190 Public
191 Property Value:String Read GetAsString write SetAsString;
192 End;
193
194
195 TSmallintField=Class(TField)
196 Protected
197 Function GetAsBoolean:Boolean;Override;
198 Procedure SetAsBoolean(NewValue:Boolean);Override;
199 Function GetAsString:String;Override;
200 Procedure SetAsString(Const NewValue:String);Override;
201 Function GetAsAnsiString:AnsiString;Override;
202 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
203 Function GetAsSmallint:Integer;Virtual;
204 Procedure SetAsSmallInt(NewValue:Integer);Virtual;
205 Function GetAsFloat:Extended;Override;
206 Procedure SetAsFloat(Const NewValue:Extended);Override;
207 Function GetAsInteger:LongInt;Override;
208 Procedure SetAsInteger(NewValue:LongInt);Override;
209 Function GetAsVariant:Variant;Override;
210 Procedure SetAsVariant(NewValue:Variant);Override;
211 Public
212 Property Value:Integer Read GetAsSmallint Write SetAsSmallInt;
213 End;
214
215
216 TIntegerField=Class(TField)
217 Protected
218 Function GetAsBoolean:Boolean;Override;
219 Procedure SetAsBoolean(NewValue:Boolean);Override;
220 Function GetAsString:String;Override;
221 Procedure SetAsString(Const NewValue:String);Override;
222 Function GetAsAnsiString:AnsiString;Override;
223 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
224 Function GetAsFloat:Extended;Override;
225 Procedure SetAsFloat(Const NewValue:Extended);Override;
226 Function GetAsInteger:LongInt;Override;
227 Procedure SetAsInteger(NewValue:LongInt);Override;
228 Function GetAsVariant:Variant;Override;
229 Procedure SetAsVariant(NewValue:Variant);Override;
230 Public
231 Property Value:LongInt Read GetAsInteger Write SetAsInteger;
232 End;
233
234
235 TAutoIncField=Class(TIntegerField)
236 End;
237
238
239 TBooleanField=Class(TField)
240 Protected
241 Function GetAsBoolean:Boolean;Override;
242 Procedure SetAsBoolean(NewValue:Boolean);Override;
243 Function GetAsString:String;Override;
244 Procedure SetAsString(Const NewValue:String);Override;
245 Function GetAsAnsiString:AnsiString;Override;
246 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
247 Function GetAsFloat:Extended;Override;
248 Procedure SetAsFloat(Const NewValue:Extended);Override;
249 Function GetAsInteger:LongInt;Override;
250 Procedure SetAsInteger(NewValue:LongInt);Override;
251 Function GetAsVariant:Variant;Override;
252 Procedure SetAsVariant(NewValue:Variant);Override;
253 Public
254 Property Value:Boolean Read GetAsBoolean Write SetAsBoolean;
255 End;
256
257
258 TFloatField=Class(TField)
259 Private
260 FPrecision:Longint;
261 Procedure SetPrecision(Value:Longint);
262 Protected
263 Function GetAsString:String;Override;
264 Procedure SetAsString(Const NewValue:String);Override;
265 Function GetAsAnsiString:AnsiString;Override;
266 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
267 Function GetAsFloat:Extended;Override;
268 Procedure SetAsFloat(Const NewValue:Extended);Override;
269 Function GetAsInteger:LongInt;Override;
270 Procedure SetAsInteger(NewValue:LongInt);Override;
271 Function GetAsVariant:Variant;Override;
272 Procedure SetAsVariant(NewValue:Variant);Override;
273 Public
274 Constructor Create;
275 Property Value:Extended Read GetAsFloat Write SetAsFloat;
276 Property Precision:Longint Read FPrecision Write SetPrecision;
277 End;
278
279
280 TCurrencyField=Class(TFloatField)
281 Public
282 Constructor Create;
283 End;
284
285
286 TDateField=Class(TField)
287 Private
288 FDisplayFormat:PString;
289 Private
290 Function GetDisplayFormat:String;
291 Procedure SetDisplayFormat(Const NewValue:String);
292 Protected
293 Function GetAsString:String;Override;
294 Procedure SetAsString(Const NewValue:String);Override;
295 Function GetAsAnsiString:AnsiString;Override;
296 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
297 Function GetAsFloat:Extended;Override;
298 Function GetAsDateTime:TDateTime;Override;
299 Procedure SetAsDateTime(NewValue:TDateTime);Override;
300 Function GetAsVariant:Variant;Override;
301 Procedure SetAsVariant(NewValue:Variant);Override;
302 Destructor Destroy;Override;
303 Public
304 Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime;
305 Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat;
306 End;
307
308
309 TTimeField=Class(TField)
310 Private
311 FDisplayFormat:PString;
312 Private
313 Function GetDisplayFormat:String;
314 Procedure SetDisplayFormat(Const NewValue:String);
315 Protected
316 Function GetAsString:String;Override;
317 Procedure SetAsString(Const NewValue:String);Override;
318 Function GetAsAnsiString:AnsiString;Override;
319 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
320 Function GetAsFloat:Extended;Override;
321 Function GetAsDateTime:TDateTime;Override;
322 Procedure SetAsDateTime(NewValue:TDateTime);Override;
323 Function GetAsVariant:Variant;Override;
324 Procedure SetAsVariant(NewValue:Variant);Override;
325 Destructor Destroy;Override;
326 Public
327 Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime;
328 Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat;
329 End;
330
331
332 TDateTimeField=Class(TField)
333 Private
334 FDisplayFormat:PString;
335 Private
336 Function GetDisplayFormat:String;
337 Procedure SetDisplayFormat(Const NewValue:String);
338 Protected
339 Function GetAsString:String;Override;
340 Procedure SetAsString(Const NewValue:String);Override;
341 Function GetAsAnsiString:AnsiString;Override;
342 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
343 Function GetAsFloat:Extended;Override;
344 Function GetAsDateTime:TDateTime;Override;
345 Procedure SetAsDateTime(NewValue:TDateTime);Override;
346 Function GetAsVariant:Variant;Override;
347 Procedure SetAsVariant(NewValue:Variant);Override;
348 Destructor Destroy;Override;
349 Public
350 Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime;
351 Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat;
352 End;
353
354
355 TBlobField=Class(TField)
356 Protected
357 Function GetAsString:String;Override;
358 Function GetAsAnsiString:AnsiString;Override;
359 Public
360 Procedure LoadFromStream(Stream:TStream);
361 Property Value:Pointer Read FValue;
362 End;
363
364
365 TMemoField=Class(TField)
366 Protected
367 Function GetAsString:String;Override;
368 Function GetAsAnsiString:AnsiString;Override;
369 Procedure SetAsAnsiString(NewValue:AnsiString);Override;
370 Public
371 Property Value:AnsiString Read GetAsAnsiString write SetAsAnsiString;
372 End;
373
374
375 TGraphicField=Class(TBlobField)
376 Protected
377 Function GetAsString:String;Override;
378 End;
379
380
381 TFieldList=Class(TList) //List Of Fields (TField entries)
382 Public
383 Procedure Clear;Override;
384 End;
385
386
387 TFieldDef=Class
388 Private
389 FFields:TList;
390 FOwner:TFieldDefs;
391 FName:String;
392 FRequired:Boolean;
393 FSize:Longword;
394 FPrecision:LongInt;
395 FDataType:TFieldType;
396 FFieldNo:Longint;
397 FPrimaryKey:Boolean;
398 FForeignKey:PString;
399 FTypeName:PString;
400 Function GetFieldClass:TFieldClass;
401 Function GetPrimaryKey:Boolean;
402 Procedure SetPrimaryKey(NewValue:Boolean);
403 Function GetForeignKey:String;
404 Procedure SetForeignKey(Const NewValue:String);
405 Function GetTypeName:String;
406 Procedure SetTypeName(Const NewValue:String);
407 Public
408 Constructor Create(aOwner:TFieldDefs; Const aName:String;
409 aDataType:TFieldType; aSize:Longword; aRequired:Boolean;
410 aFieldNo:Longint);
411 Destructor Destroy;Override;
412 Function CreateField(Owner:TComponent):TField;
413 Public
414 Property Fields:TList Read FFields;
415 Property DataType:TFieldType Read FDataType;
416 Property FieldClass:TFieldClass Read GetFieldClass;
417 Property FieldNo:Longint Read FFieldNo;
418 Property Name:String Read FName;
419 Property TypeName:String Read GetTypeName write SetTypeName;
420 Property Precision:Longint Read FPrecision Write FPrecision;
421 Property Required:Boolean Read FRequired;
422 Property Size:Longword Read FSize Write FSize;
423 Property PrimaryKey:Boolean read GetPrimaryKey write FPrimaryKey;
424 Property ForeignKey:String read GetForeignKey write SetForeignKey;
425 End;
426
427
428 TFieldDefs=Class
429 Private
430 FDataSet:TDataSet;
431 FItems:TList;
432 Function Rows:Longint;
433 Function GetCount:Longint;
434 Function GetItem(Index:Longint):TFieldDef;
435 Public
436 Constructor Create(DataSet:TDataSet);
437 Destructor Destroy;Override;
438 Procedure Clear;
439 Function Add(Const Name:String; DataType:TFieldType; Size:Longint; Required:Boolean):TFieldDef;
440 Procedure Update;
441 Procedure Assign(FieldDefs: TFieldDefs);
442 Function Find(Const Name: string): TFieldDef;
443 Function IndexOf(Const Name: string): LongInt;
444 Public
445 Property Count:Longint Read GetCount;
446 Property Items[Index:Longint]:TFieldDef Read GetItem; default
447 End;
448
449 TDataSetNotifyEvent=Procedure(DataSet:TDataSet) Of Object;
450
451 {$M+}
452 TLocateOptions=Set Of (loCaseInsensitive,loPartialKey);
453 {$M-}
454
455 {$M+}
456 TIndexOptions = Set of (ixPrimary, ixUnique, ixDescending,
457 ixCaseInsensitive, ixExpression);
458 {$M-}
459
460 TDataSet=Class(TComponent)
461 Private
462 FCurrentRow:LongInt;
463 FCurrentField:LongInt;
464 FRowIsInserted:Boolean;
465 FFieldDefs:TFieldDefs;
466 FActive:Boolean;
467 FOpened:Boolean;
468 FDBProcs:TDBProcs;
469 FServer:PString;
470 FDataBase:PString;
471 FDataSetLocked:Boolean;
472 FRefreshOnLoad:Boolean;
473 FSelect:TStrings;
474 FDataChangeLock:Boolean;
475 FMaxRows:LongInt;
476 FBeforeOpen:TDataSetNotifyEvent;
477 FAfterOpen:TDataSetNotifyEvent;
478 FBeforeClose:TDataSetNotifyEvent;
479 FAfterClose:TDataSetNotifyEvent;
480 FBeforeInsert:TDataSetNotifyEvent;
481 FAfterInsert:TDataSetNotifyEvent;
482 FBeforePost:TDataSetNotifyEvent;
483 FAfterPost:TDataSetNotifyEvent;
484 FBeforeCancel:TDataSetNotifyEvent;
485 FAfterCancel:TDataSetNotifyEvent;
486 FBeforeDelete:TDataSetNotifyEvent;
487 FAfterDelete:TDataSetNotifyEvent;
488 FReadOnly:Boolean;
489 Private
490 Function GetBOF:Boolean;
491 Function GetEOF:Boolean;
492 Function GetField(Index:LongInt):TField;
493 Function GetFieldCount:LongInt;
494 Function GetFieldName(Index:LongInt):String;
495 Function GetFieldType(Index:LongInt):TFieldType;
496 Procedure SetCurrentField(NewValue:LongInt);
497 Procedure SetCurrentRow(NewValue:LongInt);
498 Procedure UpdateField(field:TField;OldValue:Pointer;OldValueLen:LongInt);
499 Function GetFieldFromColumnName(ColumnName:String):TField;
500 Procedure CheckRequiredFields;
501 Procedure SetFieldDefs(NewValue:TFieldDefs);
502 Procedure DesignerNotification(Var DNS:TDesignerNotifyStruct);
503 Function IsTable:Boolean;
504 Protected
505 Procedure SetupComponent;Override;
506 Procedure Loaded;Override;
507 Procedure DataChange(event:TDataChange);Virtual;
508 Procedure CheckInactive;Virtual;
509 Procedure SetActive(NewValue:Boolean);Virtual;
510 Procedure SetDataBaseName(Const NewValue:String);Virtual;
511 Function GetDataBaseName:String;Virtual;
512 Procedure SetServer(Const NewValue:String);Virtual;
513 Function GetServer:String;Virtual;
514 Function GetMaxRows:LongInt;Virtual;
515 Function GetResultColRow(Col,Row:LongInt):TField;Virtual;
516 Procedure CommitInsert(Commit:Boolean);Virtual;
517 Function UpdateFieldSelect(Field:TField):Boolean;Virtual;
518 Function GetFieldClass(FieldType:TFieldType):TFieldClass;Virtual;
519 Procedure InsertCurrentFields;
520 Procedure RemoveCurrentFields;
521 Procedure QueryTable;Virtual;
522 Procedure DoOpen;Virtual;
523 Procedure DoClose;Virtual;
524 Procedure DoPost;Virtual;
525 Procedure DoCancel;Virtual;
526 Procedure DoInsert;Virtual;
527 Procedure DoDelete;Virtual;
528 Property DataSetLocked:Boolean read FDataSetLocked write FDataSetLocked;
529 Public
530 Destructor Destroy;Override;
531 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
532 Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override;
533 Procedure Open;
534 Procedure Close;
535 Procedure First;
536 Procedure Last;
537 Procedure Next;
538 Procedure Prior;
539 Procedure MoveBy(Distance:LongInt);
540 Procedure Refresh;
541 Procedure Post;Virtual;
542 Procedure Cancel;Virtual;
543 Procedure Insert;Virtual;
544 Procedure Append;Virtual;
545 Procedure Delete;Virtual;
546 Procedure GetFieldNames(List:TStrings);
547 Procedure GetDataSources(List:TStrings);Virtual;
548 Procedure GetStoredProcNames(List:TStrings);Virtual;
549 Procedure RefreshTable;Virtual;
550 Procedure AppendRecord(Const values:Array Of Const);
551 Procedure SetFields(Const values:Array Of Const);
552 Procedure InsertRecord(Const Values:Array Of Const);Virtual;
553 Function FieldByName(Const FieldName:String):TField;
554 Function FindField(Const FieldName:String):TField;
555 Function FindFirst: Boolean;
556 Function FindLast: Boolean;
557 Function FindNext: Boolean;
558 Function FindPrior: Boolean;
559 Procedure GetFieldList(List:TList;Const FieldNames:String);
560 Function Locate(Const KeyFields:String;Const KeyValues:Array Of Const;
561 Options:TLocateOptions):Boolean;Virtual;
562 Public
563 Property Bof:Boolean Read GetBOF;
564 Property Eof:Boolean Read GetEOF;
565 Property FieldCount:LongInt Read GetFieldCount;
566 Property Fields[Index:LongInt]:TField Read GetField;
567 Property FieldDefs:TFieldDefs read FFieldDefs write SetFieldDefs;
568 Property FieldNames[Index:LongInt]:String Read GetFieldName;
569 Property FieldTypes[Index:LongInt]:TFieldType Read GetFieldType;
570 Property CurrentField:LongInt Read FCurrentField Write SetCurrentField;
571 Property CurrentRow:LongInt Read FCurrentRow Write SetCurrentRow;
572 Property RowInserted:Boolean Read FRowIsInserted write FRowIsInserted;
573 Property FieldFromColumnName[ColumnName:String]:TField Read GetFieldFromColumnName;
574 Property DataChangeLock:Boolean Read FDataChangeLock Write FDataChangeLock;
575 Property MaxRows:LongInt read GetMaxRows;
576 Property RecordCount:Longint read GetMaxRows;
577 Property RecNo:Longint read FCurrentRow;
578 Property DataBaseName:String Read GetDataBaseName Write SetDataBaseName;
579 Published
580 Property Active:Boolean Read FActive Write SetActive;
581 Property Server:String Read GetServer Write SetServer;
582 Property DataBase:String Read GetDataBaseName Write SetDataBaseName;
583 Property ReadOnly:Boolean read FReadOnly write FReadOnly;
584 Property BeforeOpen:TDataSetNotifyEvent Read FBeforeOpen Write FBeforeOpen;
585 Property AfterOpen:TDataSetNotifyEvent Read FAfterOpen Write FAfterOpen;
586 Property BeforeClose:TDataSetNotifyEvent Read FBeforeClose Write FBeforeClose;
587 Property AfterClose:TDataSetNotifyEvent Read FAfterClose Write FAfterClose;
588 Property BeforeInsert:TDataSetNotifyEvent Read FBeforeInsert Write FBeforeInsert;
589 Property AfterInsert:TDataSetNotifyEvent Read FAfterInsert Write FAfterInsert;
590 Property BeforePost:TDataSetNotifyEvent Read FBeforePost Write FBeforePost;
591 Property AfterPost:TDataSetNotifyEvent Read FAfterPost Write FAfterPost;
592 Property BeforeCancel:TDataSetNotifyEvent Read FBeforeCancel Write FBeforeCancel;
593 Property AfterCancel:TDataSetNotifyEvent Read FAfterCancel Write FAfterCancel;
594 Property BeforeDelete:TDataSetNotifyEvent Read FBeforeDelete Write FBeforeDelete;
595 Property AfterDelete:TDataSetNotifyEvent Read FAfterDelete Write FAfterDelete;
596 End;
597
598 TLockType=(ltReadLock,ltWriteLock);
599
600 TIndexDefs=Class;
601
602 TIndexDef=Class
603 Private
604 FOwner: TIndexDefs;
605 FName:PString;
606 FFields:PString;
607 FOptions:TIndexOptions;
608 Function GetFields:String;
609 Function GetName:String;
610 Public
611 Constructor Create(Owner:TIndexDefs;Const Name, Fields:String;
612 Options:TIndexOptions);
613 Destructor Destroy; override;
614 Public
615 Property Fields:String read GetFields;
616 Property Name:String read GetName;
617 Property Options: TIndexOptions read FOptions;
618 End;
619
620 TIndexDefs=Class
621 Private
622 FDataSet:TDataSet;
623 FItems:TList;
624 FUpdated: Boolean;
625 Function GetCount:LongInt;
626 Function GetItem(Index:LongInt): TIndexDef;
627 Public
628 Constructor Create(DataSet:TDataSet);
629 Destructor Destroy;Override;
630 Function Add(Const Name,Fields:String;Options:TIndexOptions):TIndexDef;
631 Procedure Assign(IndexDefs:TIndexDefs);
632 Procedure Clear;
633 Function FindIndexForFields(Const Fields:String):TIndexDef;
634 Function GetIndexForFields(Const Fields:String;CaseInsensitive:Boolean):TIndexDef;
635 Function IndexOf(Const Name:String):LongInt;
636 Procedure Update;
637 Public
638 Property Count:LongInt read GetCount;
639 Property Items[Index:LongInt]:TIndexDef read GetItem;default;
640 Property Updated:Boolean read FUpdated write FUpdated;
641 End;
642
643 TTable=Class(TDataSet)
644 Private
645 FTableName:PString;
646 FMasterSource:TDataSource;
647 FTempMasterSource:TDataSource;
648 FMasterFields:PString;
649 FServants:TList; //Servants that are connected With This
650 FDataTypes:TStringList;
651 FIndexDefs:TIndexDefs;
652 FIndexFieldMap:TList;
653 Private
654 Function GetPassword:String;
655 Function GetUserId:String;
656 Procedure SetPassword(NewValue:String);
657 Procedure SetUserId(NewValue:String);
658 Procedure SetTableName(NewValue:String);
659 Function GetTableName:String;
660 Procedure SetTableLock(LockType:TLockType;Lock:Boolean);
661 Procedure SetMasterSource(NewValue:TDataSource);
662 Function GetMasterFields:String;
663 Procedure SetMasterFields(Const NewValue:String);
664 Procedure ConnectServant(Servant:TTable;Connect:Boolean);
665 Procedure CloseStmt;
666 Procedure GetNames(List:TStrings;Const Name:String);
667 Procedure GetKeys(List:TStrings;Primary:Boolean);
668 Function GetIndexFieldCount:LongInt;
669 Function GetIndexField(Index:LongInt):TField;
670 Procedure SetIndexField(Index:LongInt;NewValue:TField);
671 Function GetIndexDefs:TIndexDefs;
672 Protected
673 Procedure SetupComponent;Override;
674 Procedure SetActive(NewValue:Boolean);Override;
675 Function GetResultColRow(Col,Row:LongInt):TField;Override;
676 Procedure CommitInsert(Commit:Boolean);Override;
677 Function UpdateFieldSelect(Field:TField):Boolean;Override;
678 Procedure DataChange(event:TDataChange);Override;
679 Procedure QueryTable;Override;
680 Procedure DoOpen;Override;
681 Procedure DoClose;Override;
682 Procedure DoDelete;Override;
683 Procedure DoCancel;Override;
684 Procedure DoPost;Override;
685 Procedure Loaded;Override;
686 Procedure UpdateLinkList(Const PropertyName:String;LinkList:TList);Override;
687 Public
688 Procedure UpdateIndexDefs;Virtual;
689 Procedure UpdateFieldDefs;
690 Destructor Destroy;Override;
691 Procedure RefreshTable;Override;
692 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
693 Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override;
694 Procedure GetDataSources(List:TStrings);Override;
695 Procedure GetStoredProcNames(List:TStrings);Override;
696 Procedure LockTable(LockType:TLockType);Virtual;
697 Procedure UnlockTable(LockType:TLockType);Virtual;
698 Procedure GetPrimaryKeys(List:TStrings);Virtual;
699 Procedure GetTableNames(List:TStrings);Virtual;
700 Procedure AddIndex(Const Name:String;Fields:String;Options:TIndexOptions);Virtual;
701 Procedure DeleteIndex(Const Name: string);Virtual;
702 Procedure CreateTable;Virtual;
703 Procedure DeleteTable;Virtual;
704 Procedure EmptyTable;Virtual;
705 Function FindKey(Const KeyValues:Array of Const):Boolean;Virtual;
706 Procedure GetIndexNames(List: TStrings);Virtual;
707 Procedure RenameTable(NewTableName:String);Virtual;
708 Procedure GetViewNames(List:TStrings);Virtual;
709 Procedure GetSystemTableNames(List:TStrings);Virtual;
710 Procedure GetSynonymNames(List:TStrings);Virtual;
711 Procedure GetDataTypes(List:TStrings);Virtual;
712 Procedure GetForeignKeys(List:TStrings);Virtual;
713 Function DataType2Name(DataType:TFieldType):String;
714 Public
715 Property IndexDefs:TIndexDefs read GetIndexDefs;
716 Property IndexFieldCount:LongInt read GetIndexFieldCount;
717 Property IndexFields[Index:LongInt]:TField read GetIndexField write SetIndexField;
718 Published
719 Property TableName:String Read GetTableName Write SetTableName;
720 Property Password:String Read GetPassword Write SetPassword;
721 Property UserId:String Read GetUserId Write SetUserId;
722 Property MasterSource:TDataSource Read FMasterSource Write SetMasterSource;
723 Property MasterFields:String Read GetMasterFields Write SetMasterFields;
724 End;
725
726
727 TQuery=Class(TTable)
728 Private
729 Property TableName;
730 Property MasterFields;
731 Property MasterSource;
732 Property ReadOnly;
733 Procedure SetSQL(NewValue:TStrings);
734 Protected
735 Procedure SetupComponent;Override;
736 Public
737 Procedure RefreshTable;Override;
738 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
739 Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override;
740 Published
741 Property SQL:TStrings Read FSelect Write SetSQL;
742 End;
743
744 TParams = Class;
745
746 TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult, ptResultSet);
747
748 TParam = Class
749 Private
750 FParamList: TParams;
751 FData: Variant;
752 FName:PString;
753 FDataType: TFieldType;
754 FNull: Boolean;
755 FBound: Boolean;
756 FParamType: TParamType;
757 FResultNTS:CString;
758 FResultLongInt:LongInt;
759 FResultSmallInt:SmallInt;
760 FResultExtended:Extended;
761 FResultDate:Record
762 Year:Word;
763 Month:Word;
764 Day:Word;
765 End;
766 FResultTime:Record
767 Hour:WORD;
768 Minute:WORD;
769 Second:WORD;
770 End;
771 FResultDateTime:Record
772 Year:Word;
773 Month:Word;
774 Day:Word;
775 Hour:WORD;
776 Minute:WORD;
777 Second:WORD;
778 Fraction:LongWord;
779 End;
780 FOutLen:SQLINTEGER;
781 Private
782 Procedure SetAsBCD(Value: Currency);
783 Procedure SetAsBoolean(Value: Boolean);
784 Procedure SetAsCurrency(Value:Extended);
785 Procedure SetAsDate(Value: TDateTime);
786 Procedure SetAsDateTime(Value: TDateTime);
787 Procedure SetAsFloat(Const Value:Extended);
788 Procedure SetAsInteger(Value: Longint);
789 Procedure SetAsString(const Value: string);
790 Procedure SetAsSmallInt(Value: LongInt);
791 Procedure SetAsTime(Value: TDateTime);
792 Procedure SetAsVariant(Value: Variant);
793 Procedure SetAsWord(Value: LongInt);
794 Function GetName:String;
795 Procedure SetName(Const NewValue:String);
796 Protected
797 Function GetAsBCD: Currency;
798 Function GetAsBoolean: Boolean;
799 Function GetAsDateTime: TDateTime;
800 Function GetAsFloat:Extended;
801 Function GetAsInteger: Longint;
802 Function GetAsString: string;
803 Function GetAsVariant: Variant;
804 Function IsEqual(Value: TParam): Boolean;
805 Procedure SetDataType(Value: TFieldType);
806 Procedure SetText(Const Value:String);
807 Public
808 Constructor Create(AParamList: TParams; AParamType: TParamType);
809 Destructor Destroy;Override;
810 Procedure Assign(Param: TParam);
811 Procedure AssignField(Field: TField);
812 Procedure AssignFieldValue(Field:TField;Const Value: Variant);
813 Procedure Clear;
814 Public
815 Property AsBCD: Currency read GetAsBCD write SetAsBCD;
816 Property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
817 Property AsCurrency:Extended read GetAsFloat write SetAsCurrency;
818 Property AsDate: TDateTime read GetAsDateTime write SetAsDate;
819 Property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
820 Property AsFloat:Extended read GetAsFloat write SetAsFloat;
821 Property AsInteger: LongInt read GetAsInteger write SetAsInteger;
822 Property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt;
823 Property AsString:String read GetAsString write SetAsString;
824 Property AsTime: TDateTime read GetAsDateTime write SetAsTime;
825 Property AsWord: LongInt read GetAsInteger write SetAsWord;
826 Property Bound: Boolean read FBound write FBound;
827 Property DataType: TFieldType read FDataType write SetDataType;
828 Property IsNull: Boolean read FNull;
829 Property Name:String read GetName write SetName;
830 Property ParamType: TParamType read FParamType write FParamType;
831 Property Text:String read GetAsString write SetText;
832 Property Value: Variant read GetAsVariant write SetAsVariant;
833 End;
834
835 TParams=Class
836 Private
837 FItems: TList;
838 Function GetParam(Index: Word): TParam;
839 Function GetParamValue(Const ParamName:String):Variant;
840 Procedure SetParamValue(Const ParamName:String;Const Value: Variant);
841 Public
842 Constructor Create;Virtual;
843 Destructor Destroy;Override;
844 Procedure AddParam(Value: TParam);
845 Procedure RemoveParam(Value: TParam);
846 Function CreateParam(FldType:TFieldType;Const ParamName:String;ParamType: TParamType): TParam;
847 Function Count:LongInt;
848 Procedure Clear;
849 Function IsEqual(Value:TParams): Boolean;
850 Function ParamByName(Const Value:String): TParam;
851 Property Items[Index: Word]: TParam read GetParam;default;
852 Property ParamValues[Const ParamName:String]: Variant read GetParamValue write SetParamValue;
853 End;
854
855 TStoredProc=Class(TTable)
856 Private
857 FPrepared:Boolean;
858 FParams:TParams;
859 FProcName:String;
860 Function GetParamCount:Word;
861 Procedure SetPrepared(NewValue:Boolean);
862 Procedure SetParams(NewValue:TParams);
863 Procedure SetStoredProcName(NewValue:String);
864 Property TableName;
865 Property MasterSource;
866 Property MasterFields;
867 Property ReadOnly;
868 Protected
869 Procedure Loaded;Override;
870 Procedure DoOpen;Override;
871 Procedure DoClose;Override;
872 Function UpdateFieldSelect(field:TField):Boolean;Override;
873 Public
874 Constructor Create(AOwner: TComponent);Override;
875 Destructor Destroy;Override;
876 Procedure Insert;Override;
877 Procedure Delete;Override;
878 Procedure InsertRecord(Const Values:Array Of Const);Override;
879 Procedure CopyParams(Value:TParams);
880 Procedure ExecProc;
881 Function ParamByName(Const Value:String):TParam;
882 Procedure Prepare;
883 Procedure UnPrepare;
884 Procedure SetDefaultParams;
885 Property ParamCount:Word read GetParamCount;
886 Property StmtHandle:SQLHStmt read FDBProcs.ahstmt;
887 Property Prepared: Boolean read FPrepared write SetPrepared;
888 Property Params:TParams read FParams write SetParams;
889 Published
890 Property StoredProcName:String read FProcName write SetStoredProcName;
891 End;
892
893
894Function Field2String(field:TField):String;
895Function ExtractFieldName(Const Fields:String;Var Pos:LongInt):String;
896
897Procedure DatabaseError(Const Message:String);
898Procedure SQLError(Const Message:String);
899
900
901
902Implementation
903
904Type
905 TGraphicHeader=Record
906 Count:Word; { Fixed at 1 }
907 HType:Word; { Fixed at $0100 }
908 Size:Longint; { Size not including header }
909 End;
910
911Const SQLProcessCount:LongWord=0;
912
913Procedure EnterSQLProcessing;
914Begin
915 Screen.Cursor:=crSQLWait;
916 inc(SQLProcessCount);
917End;
918
919Procedure LeaveSQLProcessing;
920Begin
921 If SQLProcessCount>0 Then dec(SQLProcessCount);
922 If SQLProcessCount=0 Then Screen.Cursor:=crDefault;
923End;
924
925Procedure DatabaseError(Const Message:String);
926Begin
927 SQLProcessCount:=0;
928 LeaveSQLProcessing;
929 Raise EDataBaseError.Create(Message);
930End;
931
932Procedure SQLError(Const Message:String);
933Begin
934 SQLProcessCount:=0;
935 LeaveSQLProcessing;
936 Raise ESQLError.Create(Message);
937End;
938
939{
940ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
941º º
942º Speed-Pascal/2 Version 2.0 º
943º º
944º Speed-Pascal Component Classes (SPCC) º
945º º
946º This section: TDataLink Class Implementation º
947º º
948º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
949º º
950ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
951}
952
953Procedure TDataLink.SetDataSource(NewValue:TDataSource);
954Begin
955 If NewValue=FDataSource Then Exit;
956 If FDataSource<>Nil Then FDataSource.Notification(Self,opRemove);
957 FDataSource:=NewValue;
958 If FDataSource<>Nil Then FDataSource.FreeNotification(Self);
959 DataChange(deDataBaseChanged);
960End;
961
962Procedure TDataLink.DataChange(event:TDataChange);
963Begin
964 If OnDataChange<>Nil Then OnDataChange(Self,event);
965End;
966
967Procedure TDataLink.Notification(AComponent:TComponent;Operation:TOperation);
968Begin
969 Inherited Notification(AComponent,Operation);
970
971 If AComponent=TComponent(FDataSource) Then If Operation=opRemove Then
972 Begin
973 FDataSource:=Nil;
974 DataChange(deDataBaseChanged);
975 End;
976End;
977
978Destructor TDataLink.Destroy;
979Begin
980 If FDataSource<>Nil Then FDataSource.Notification(Self,opRemove);
981 FDataSource:=Nil;
982 DataChange(deDataBaseChanged);
983 Inherited Destroy;
984End;
985
986Procedure TDataLink.SetupComponent;
987Begin
988 Inherited SetupComponent;
989
990 Name:='DataLink';
991 If Owner<>Nil Then SetDesigning(Owner.Designed);
992End;
993
994{
995ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
996º º
997º Speed-Pascal/2 Version 2.0 º
998º º
999º Speed-Pascal Component Classes (SPCC) º
1000º º
1001º This section: TTableDataLink Class Implementation º
1002º º
1003º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1004º º
1005ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1006}
1007
1008Function TTableDataLink.GetColRowField(Col,Row:LongInt):TField;
1009Begin
1010 Result:=Nil;
1011 If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1012 Result:=FDataSource.DataSet.GetResultColRow(Col,Row);
1013End;
1014
1015Function TTableDataLink.GetNameRowField(Name:String;Row:LongInt):TField;
1016Var Col:LongInt;
1017 S:String;
1018 T:LongInt;
1019Label Ok;
1020Begin
1021 Result:=Nil;
1022 If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1023
1024 UpcaseStr(Name);
1025 For T:=0 To FDataSource.DataSet.FieldCount-1 Do
1026 Begin
1027 S:=FDataSource.DataSet.FieldNames[T];
1028 UpcaseStr(S);
1029 If S=Name Then
1030 Begin
1031 Col:=T;
1032 Goto Ok;
1033 End;
1034 End;
1035 Exit;
1036Ok:
1037 Result:=FDataSource.DataSet.GetResultColRow(Col,Row);
1038End;
1039
1040Procedure TTableDataLink.SetupComponent;
1041Begin
1042 Inherited SetupComponent;
1043 Name:='TableDataLink';
1044End;
1045
1046Function TTableDataLink.GetFieldCount:LongInt;
1047Begin
1048 Result:=0;
1049 If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1050 Result:=FDataSource.DataSet.FieldCount;
1051End;
1052
1053Function TTableDataLink.GetFieldName(Index:LongInt):String;
1054Begin
1055 Result:='';
1056 If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1057 Result:=FDataSource.DataSet.FieldNames[Index];
1058End;
1059
1060{
1061ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1062º º
1063º Speed-Pascal/2 Version 2.0 º
1064º º
1065º Speed-Pascal Component Classes (SPCC) º
1066º º
1067º This section: TFieldDataLink Class Implementation º
1068º º
1069º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1070º º
1071ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1072}
1073
1074Procedure TFieldDataLink.SetFieldName(Const NewValue:String);
1075Begin
1076 If GetFieldName=NewValue Then exit;
1077
1078 AssignStr(FFieldName,NewValue);
1079 DataChange(deDataBaseChanged);
1080End;
1081
1082Function TFieldDataLink.GetFieldName:String;
1083Begin
1084 Result:=FFieldName^;
1085End;
1086
1087Procedure TFieldDataLink.SetupComponent;
1088Begin
1089 AssignStr(FFieldName,'');
1090
1091 Inherited SetupComponent;
1092
1093 Name:='FieldDataLink';
1094End;
1095
1096Function TFieldDataLink.GetField:TField;
1097Var T:LongInt;
1098 S,s1:String;
1099Begin
1100 Result:=Nil;
1101 S:=GetFieldName;
1102 If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)Or(S='')) Then Exit;
1103 UpcaseStr(S);
1104 For T:=0 To FDataSource.DataSet.FieldCount-1 Do
1105 Begin
1106 s1:=FDataSource.DataSet.FieldNames[T];
1107 UpcaseStr(s1);
1108 If S=s1 Then
1109 Begin
1110 Result:=FDataSource.DataSet.Fields[T];
1111 Exit;
1112 End;
1113 End;
1114End;
1115
1116Destructor TFieldDataLink.Destroy;
1117Begin
1118 AssignStr(FFieldName,'');
1119
1120 Inherited Destroy;
1121End;
1122
1123{
1124ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1125º º
1126º Speed-Pascal/2 Version 2.0 º
1127º º
1128º Speed-Pascal Component Classes (SPCC) º
1129º º
1130º This section: TDataSource Class Implementation º
1131º º
1132º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1133º º
1134ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1135}
1136
1137//This tables DataSource changes, notify All Servants linked With MasterSource
1138Procedure NotifyServants(Table:TTable);
1139Var T:LongInt;
1140 Servant:TTable;
1141Begin
1142 If Table.FServants<>Nil Then
1143 Begin
1144 //notify All Servants that their MasterSource Is invalid
1145 For T:=0 To Table.FServants.Count-1 Do
1146 Begin
1147 Servant:=Table.FServants[T];
1148 Servant.FMasterSource:=Nil;
1149 If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then
1150 Servant.RefreshTable;
1151 End;
1152 Table.FServants.Clear;
1153 End;
1154End;
1155
1156Procedure TDataSource.SetDataSet(NewValue:TDataSet);
1157Var Table,Servant:TTable;
1158 T:LongInt;
1159Begin
1160 If FDataSet<>Nil Then
1161 Begin
1162 If FDataSet Is TTable Then
1163 Begin
1164 If Not (NewValue Is TTable) Then NotifyServants(TTable(FDataSet))
1165 Else If NewValue<>FDataSet Then
1166 Begin
1167 //New DataSet Is also A Table
1168 //Link All Servants Of This Table To the New one
1169 Table:=TTable(FDataSet);
1170 If Table.FServants<>Nil Then
1171 Begin
1172 For T:=0 To Table.FServants.Count-1 Do
1173 Begin
1174 Servant:=Table.FServants[T];
1175 TTable(NewValue).ConnectServant(Servant,True);
1176 End;
1177 Table.FServants.Clear;
1178 End;
1179 End;
1180 End;
1181
1182 FDataSet.Notification(Self,opRemove);
1183 End;
1184 FDataSet:=NewValue;
1185 If FDataSet<>Nil Then FDataSet.FreeNotification(Self);
1186 DataChange(deDataBaseChanged);
1187End;
1188
1189Destructor TDataSource.Destroy;
1190Begin
1191 If FDataSet Is TTable Then NotifyServants(TTable(FDataSet));
1192 If FDataSet<>Nil Then FDataSet.Notification(Self,opRemove);
1193 FDataSet:=Nil;
1194 Inherited Destroy;
1195End;
1196
1197Procedure TDataSource.SetupComponent;
1198Begin
1199 Include(ComponentState, csHandleLinks);
1200 Inherited SetupComponent;
1201
1202// Include(DesignerState,dsDetail);
1203 Name:='DataSource';
1204End;
1205
1206Procedure TDataSource.DataChange(event:TDataChange);
1207Var T:LongInt;
1208 Link:TDataLink;
1209 FLinkList:TList;
1210Begin
1211 FLinkList:=FreeNotifyList;
1212 If FLinkList<>Nil Then For T:=0 To FLinkList.Count-1 Do
1213 Begin
1214 Link:=FLinkList.Items[T];
1215 If Link Is TDataLink Then Link.DataChange(event);
1216 End;
1217End;
1218
1219Procedure TDataSource.Notification(AComponent:TComponent;Operation:TOperation);
1220Begin
1221 Inherited Notification(AComponent,Operation);
1222
1223 If AComponent=TComponent(FDataSet) Then If Operation=opRemove Then
1224 Begin
1225 FDataSet:=Nil;
1226 DataChange(deDataBaseChanged);
1227 If OnDataChange<>Nil Then OnDataChange(Self,deDataBaseChanged);
1228 End;
1229End;
1230
1231{
1232ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1233º º
1234º Speed-Pascal/2 Version 2.0 º
1235º º
1236º Speed-Pascal Component Classes (SPCC) º
1237º º
1238º This section: TField Class Implementation º
1239º º
1240º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1241º º
1242ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1243}
1244
1245Function TField.GetIsIndexField:Boolean;
1246Var s,s1,s2:String;
1247 t:LongInt;
1248 IndexDef:TIndexDef;
1249Begin
1250 Result:=False;
1251 If not (FDataSet Is TTable) Then exit;
1252 s:=FieldName;
1253 UpcaseStr(s);
1254 For t:=0 To TTable(FDataSet).IndexDefs.Count-1 Do
1255 Begin
1256 IndexDef:=TTable(FDataSet).IndexDefs[t];
1257 s1:=IndexDef.Fields;
1258 UpcaseStr(s1);
1259 While pos(';',s1)<>0 Do
1260 Begin
1261 s2:=Copy(s1,1,pos(';',s1)-1);
1262 Delete(s1,1,pos(';',s1));
1263 If s=s2 Then
1264 Begin
1265 Result:=True;
1266 exit;
1267 End;
1268 End;
1269 If s=s1 Then Result:=True;
1270 End;
1271End;
1272
1273Function TField.GetReadOnly:Boolean;
1274Begin
1275 Result:=FReadOnly Or FDataSet.ReadOnly;
1276End;
1277
1278Function TField.GetCanModify:Boolean;
1279Begin
1280 Result:=not ReadOnly;
1281End;
1282
1283Procedure TField.SetData(Buffer:Pointer);
1284Begin
1285 If ReadOnly Then DataBaseError('Cannot modify a readonly field !');
1286
1287 If FValueLen > 0 Then
1288 Begin
1289 If FValue<>Nil Then FreeMem(FValue,FValueLen);
1290 FValue:=Nil;
1291 If Buffer<>Nil Then
1292 Begin
1293 GetMem(FValue,FValueLen);
1294 Move(Buffer^,FValue^,FValueLen);
1295 End;
1296 End;
1297End;
1298
1299Procedure TField.Assign(Field:TField);
1300Begin
1301 If ReadOnly Then DataBaseError('Cannot modify a readonly field !');
1302
1303 If Field=Nil Then
1304 Begin
1305 Clear;
1306 If FValueLen<>0 Then FreeMem(FValue,FValueLen);
1307 FValueLen:=0;
1308 FValue:=Nil;
1309 exit;
1310 End;
1311
1312 Value:=Field.Value;
1313End;
1314
1315Function TField.GetAsVariant:Variant;
1316Begin
1317 AccessError('Variant');
1318End;
1319
1320Procedure TField.SetAsVariant(NewValue:Variant);
1321Begin
1322 AccessError('Variant');
1323End;
1324
1325Function TField.GetFieldName:String;
1326Begin
1327 If FFieldDef <> Nil Then Result := FFieldDef.Name
1328 Else Result:='';
1329End;
1330
1331Function TField.GetIsNull:Boolean;
1332Begin
1333 Result:=FValue=Nil;
1334End;
1335
1336Destructor TField.Destroy;
1337Begin
1338 If FValue<>Nil Then
1339 If FValueLen>0 Then FreeMem(FValue,FValueLen);
1340 FValueLen:=0;
1341 FValue:=Nil;
1342
1343 Inherited Destroy;
1344End;
1345
1346Procedure TField.Clear;
1347Var OldValue:Pointer;
1348 OldValueLen:LongInt;
1349Begin
1350 //SetNewValue(Nil,0);
1351
1352 OldValue := FValue;
1353 OldValueLen := FValueLen;
1354 FValueLen := 0;
1355 FValue := Nil;
1356 FDataSet.UpdateField(Self,OldValue,OldValueLen);
1357 {wo wird der alte Speicher wieder freigegeben???}
1358End;
1359
1360
1361Procedure TField.FreeMemory;
1362Begin
1363 If (FValue <> Nil) And (FValueLen > 0) Then FreeMem(FValue,FValueLen);
1364 FValueLen := 0;
1365 FValue := Nil;
1366End;
1367
1368Procedure TField.GetMemory(Size:Longint);
1369Begin
1370 FValueLen := Size;
1371 GetMem(FValue,FValueLen);
1372End;
1373
1374
1375Procedure TField.AccessError(Const TypeName:String);
1376Begin
1377 DatabaseError('Invalid type conversion to '+TypeName+' in field: '+FieldName);
1378End;
1379
1380
1381Procedure TField.CheckInactive;
1382Begin
1383 If FDataSet <> Nil Then FDataSet.CheckInactive;
1384End;
1385
1386
1387{$HINTS OFF}
1388Procedure TField.SetAsValue(Var Value;Len:LongInt);
1389Begin
1390 SetNewValue(Value,Len);
1391End;
1392
1393Function TField.GetAsString:String;
1394Begin
1395 AccessError('String');
1396End;
1397
1398Procedure TField.SetAsString(Const NewValue:String);
1399Begin
1400 AccessError('String');
1401End;
1402
1403Function TField.GetAsAnsiString:AnsiString;
1404Begin
1405 AccessError('AnsiString');
1406End;
1407
1408Procedure TField.SetAsAnsiString(NewValue:AnsiString);
1409Begin
1410 AccessError('AnsiString');
1411End;
1412
1413Function TField.GetAsBoolean:Boolean;
1414Begin
1415 AccessError('Boolean');
1416End;
1417
1418Procedure TField.SetAsBoolean(NewValue:Boolean);
1419Begin
1420 AccessError('Boolean');
1421End;
1422
1423Function TField.GetAsDateTime:TDateTime;
1424Begin
1425 AccessError('DateTime');
1426End;
1427
1428Procedure TField.SetAsDateTime(NewValue:TDateTime);
1429Begin
1430 AccessError('DateTime');
1431End;
1432
1433Function TField.GetAsFloat:Extended;
1434Begin
1435 AccessError('Float');
1436End;
1437
1438Procedure TField.SetAsFloat(Const NewValue:Extended);
1439Begin
1440 AccessError('Float');
1441End;
1442
1443Function TField.GetAsInteger:LongInt;
1444Begin
1445 AccessError('Integer');
1446End;
1447
1448Procedure TField.SetAsInteger(NewValue:LongInt);
1449Begin
1450 AccessError('Integer');
1451End;
1452{$HINTS ON}
1453
1454Procedure TField.SetNewValue(Var NewValue;NewLen:LongInt);
1455Var OldValue:Pointer;
1456 OldValueLen:LongInt;
1457Begin
1458 If ReadOnly Then DataBaseError('Cannot modify a readonly field !');
1459
1460 OldValue:=FValue;
1461 OldValueLen:=FValueLen;
1462 FValueLen:=NewLen;
1463 If FValueLen > 0 Then
1464 Begin
1465 GetMem(FValue,FValueLen);
1466 Move(NewValue,FValue^,FValueLen);
1467 End;
1468 FDataSet.UpdateField(Self,OldValue,OldValueLen);
1469 {wo wird der alte Speicher wieder freigegeben???}
1470End;
1471
1472{
1473ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1474º º
1475º Speed-Pascal/2 Version 2.0 º
1476º º
1477º Speed-Pascal Component Classes (SPCC) º
1478º º
1479º This section: TStringField Class Implementation º
1480º º
1481º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1482º º
1483ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1484}
1485
1486Function TStringField.GetAsVariant:Variant;
1487Begin
1488 Result:=GetAsString;
1489End;
1490
1491Procedure TStringField.SetAsVariant(NewValue:Variant);
1492Begin
1493 SetAsString(NewValue);
1494End;
1495
1496Function TStringField.GetAsString:String;
1497Begin
1498 If FValue <> Nil Then
1499 Begin
1500 Result[0] := Chr(FValueLen);
1501 Move(FValue^,Result[1],Ord(Result[0]));
1502 If Result[Length(Result)]=#0 Then
1503 If length(Result)>0 Then Dec(Result[0]);
1504 End
1505 //Else Result:='NULL';
1506 Else Result := '';
1507End;
1508
1509Procedure TStringField.SetAsString(Const NewValue:String);
1510Var C:CString;
1511Begin
1512 If NewValue <> '' Then
1513 Begin
1514 C:=NewValue;
1515 SetNewValue(C,Length(NewValue)+1);
1516 End
1517 Else Clear;
1518End;
1519
1520Function TStringField.GetAsAnsiString:AnsiString;
1521Begin
1522 If FValue<>Nil Then Result:=PChar(Value)^
1523 Else Result:='';
1524End;
1525
1526Procedure TStringField.SetAsAnsiString(NewValue:AnsiString);
1527Begin
1528 If PChar(NewValue) = Nil Then NewValue:=#0;
1529 SetNewValue(PChar(NewValue)^,length(PChar(NewValue)^)+1)
1530End;
1531
1532Function TStringField.GetAsBoolean:Boolean;
1533Var S:String;
1534Begin
1535 S:=GetAsString;
1536 UpcaseStr(S);
1537 If ((S='TRUE')Or(S='YES')Or(S='1')) Then Result:=True
1538 Else Result:=False
1539End;
1540
1541Procedure TStringField.SetAsBoolean(NewValue:Boolean);
1542Var S:String;
1543Begin
1544 If NewValue Then S:='True'
1545 Else S:='False';
1546 SetAsString(S);
1547End;
1548
1549Function TStringField.GetAsDateTime:TDateTime;
1550Begin
1551 Result:=StrToDateTime(GetAsString);
1552End;
1553
1554Function TStringField.GetAsFloat:Extended;
1555Begin
1556 Result:=StrToFloat(GetAsString);
1557End;
1558
1559Procedure TStringField.SetAsFloat(Const NewValue:Extended);
1560Begin
1561 SetAsString(FloatToStr(NewValue));
1562End;
1563
1564Function TStringField.GetAsInteger:LongInt;
1565Begin
1566 Result:=StrToInt(GetAsString);
1567End;
1568
1569Procedure TStringField.SetAsInteger(NewValue:LongInt);
1570Begin
1571 SetAsString(tostr(NewValue));
1572End;
1573
1574{
1575ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1576º º
1577º Speed-Pascal/2 Version 2.0 º
1578º º
1579º Speed-Pascal Component Classes (SPCC) º
1580º º
1581º This section: TSmallintField Class Implementation º
1582º º
1583º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1584º º
1585ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1586}
1587
1588Function TSmallIntField.GetAsVariant:Variant;
1589Begin
1590 Result:=GetAsSmallInt;
1591End;
1592
1593Procedure TSmallIntField.SetAsVariant(NewValue:Variant);
1594Begin
1595 SetAsSmallInt(NewValue);
1596End;
1597
1598
1599Function TSmallintField.GetAsString:String;
1600Begin
1601 If FValue<>Nil Then Result:=tostr(Integer(FValue^))
1602 Else Result:='';
1603End;
1604
1605Procedure TSmallintField.SetAsString(Const NewValue:String);
1606Var I,C:Integer;
1607Begin
1608 If NewValue <> '' Then
1609 Begin
1610 Val(NewValue,I,C);
1611 If C=0 Then SetNewValue(I,SizeOf(Integer));
1612 End
1613 Else Clear;
1614End;
1615
1616Function TSmallintField.GetAsAnsiString:AnsiString;
1617Begin
1618 Result:=GetAsString;
1619End;
1620
1621Procedure TSmallintField.SetAsAnsiString(NewValue:AnsiString);
1622Begin
1623 SetAsString(NewValue);
1624End;
1625
1626Function TSmallintField.GetAsBoolean:Boolean;
1627Var I:Integer;
1628Begin
1629 I:=GetAsInteger;
1630 Result:=I<>0;
1631End;
1632
1633Procedure TSmallintField.SetAsBoolean(NewValue:Boolean);
1634Begin
1635 If NewValue Then SetAsInteger(1)
1636 Else SetAsInteger(0);
1637End;
1638
1639Function TSmallintField.GetAsSmallint:Integer;
1640Begin
1641 If FValue<>Nil Then Result:=Integer(FValue^)
1642 Else AccessError('Smallint');
1643End;
1644
1645Procedure TSmallintField.SetAsSmallInt(NewValue:Integer);
1646Begin
1647 SetNewValue(NewValue,SizeOf(Integer));
1648End;
1649
1650Function TSmallintField.GetAsFloat:Extended;
1651Begin
1652 If FValue<>Nil Then Result:=Integer(FValue^)
1653 Else AccessError('Float');
1654End;
1655
1656Procedure TSmallintField.SetAsFloat(Const NewValue:Extended);
1657Begin
1658 SetAsSmallInt(Round(NewValue));
1659End;
1660
1661Function TSmallintField.GetAsInteger:LongInt;
1662Begin
1663 If FValue<>Nil Then Result:=Integer(FValue^)
1664 Else AccessError('Integer');
1665End;
1666
1667Procedure TSmallintField.SetAsInteger(NewValue:LongInt);
1668Begin
1669 SetAsSmallInt(NewValue);
1670End;
1671
1672{
1673ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1674º º
1675º Speed-Pascal/2 Version 2.0 º
1676º º
1677º Speed-Pascal Component Classes (SPCC) º
1678º º
1679º This section: TIntegerField Class Implementation º
1680º º
1681º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1682º º
1683ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1684}
1685
1686
1687Function TIntegerField.GetAsVariant:Variant;
1688Begin
1689 Result:=GetAsInteger;
1690End;
1691
1692Procedure TIntegerField.SetAsVariant(NewValue:Variant);
1693Begin
1694 SetAsInteger(NewValue);
1695End;
1696
1697Function TIntegerField.GetAsString:String;
1698Begin
1699 If FValue<>Nil Then Result:=tostr(LongInt(FValue^))
1700 Else Result:='';
1701End;
1702
1703Procedure TIntegerField.SetAsString(Const NewValue:String);
1704Var I:LongInt;
1705 C:Integer;
1706Begin
1707 If NewValue <> '' Then
1708 Begin
1709 Val(NewValue,I,C);
1710 If C=0 Then SetNewValue(I,SizeOf(LongInt))
1711 Else AccessError('String');
1712 End
1713 Else Clear;
1714End;
1715
1716Function TIntegerField.GetAsAnsiString:AnsiString;
1717Begin
1718 Result:=GetAsString;
1719End;
1720
1721Procedure TIntegerField.SetAsAnsiString(NewValue:AnsiString);
1722Begin
1723 SetAsString(NewValue);
1724End;
1725
1726Function TIntegerField.GetAsBoolean:Boolean;
1727Var I:Integer;
1728Begin
1729 I:=GetAsInteger;
1730 Result:=I<>0;
1731End;
1732
1733Procedure TIntegerField.SetAsBoolean(NewValue:Boolean);
1734Begin
1735 If NewValue Then SetAsInteger(1)
1736 Else SetAsInteger(0);
1737End;
1738
1739Function TIntegerField.GetAsFloat:Extended;
1740Begin
1741 If FValue<>Nil Then Result:=LongInt(FValue^)
1742 Else AccessError('Float');
1743End;
1744
1745Procedure TIntegerField.SetAsFloat(Const NewValue:Extended);
1746Begin
1747 SetAsInteger(Round(NewValue));
1748End;
1749
1750Function TIntegerField.GetAsInteger:LongInt;
1751Begin
1752 If FValue<>Nil Then Result:=LongInt(FValue^)
1753 Else AccessError('Integer');
1754End;
1755
1756Procedure TIntegerField.SetAsInteger(NewValue:LongInt);
1757Begin
1758 SetNewValue(NewValue,SizeOf(LongInt));
1759End;
1760
1761{
1762ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1763º º
1764º Speed-Pascal/2 Version 2.0 º
1765º º
1766º Speed-Pascal Component Classes (SPCC) º
1767º º
1768º This section: TBooleanField Class Implementation º
1769º º
1770º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1771º º
1772ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1773}
1774
1775Function TBooleanField.GetAsVariant:Variant;
1776Begin
1777 Result:=GetAsBoolean;
1778End;
1779
1780Procedure TBooleanField.SetAsVariant(NewValue:Variant);
1781Begin
1782 SetAsBoolean(NewValue);
1783End;
1784
1785
1786Function TBooleanField.GetAsString:String;
1787Begin
1788 If FValue<>Nil Then
1789 Begin
1790 If Boolean(FValue^) Then Result:='True'
1791 Else Result:='False';
1792 End
1793 Else Result:='';
1794End;
1795
1796Procedure TBooleanField.SetAsString(Const NewValue:String);
1797Var s:String;
1798Begin
1799 If NewValue <> '' Then
1800 Begin
1801 s:=NewValue;
1802 UpcaseStr(s);
1803
1804 If ((s='TRUE')Or(s='YES')Or(s='T')Or(s='Y')Or(s='1')) Then SetAsBoolean(True)
1805 Else SetAsBoolean(False);
1806 End
1807 Else Clear;
1808End;
1809
1810Function TBooleanField.GetAsAnsiString:AnsiString;
1811Begin
1812 Result:=GetAsString;
1813End;
1814
1815Procedure TBooleanField.SetAsAnsiString(NewValue:AnsiString);
1816Begin
1817 SetAsString(NewValue);
1818End;
1819
1820Function TBooleanField.GetAsBoolean:Boolean;
1821Begin
1822 If FValue<>Nil Then
1823 Begin
1824 Result := Boolean(FValue^);
1825 End
1826 Else Result:=False;
1827End;
1828
1829Procedure TBooleanField.SetAsBoolean(NewValue:Boolean);
1830Begin
1831 SetNewValue(NewValue,SizeOf(Boolean))
1832End;
1833
1834Function TBooleanField.GetAsFloat:Extended;
1835Begin
1836 If FValue<>Nil Then
1837 Begin
1838 If Boolean(FValue^) Then Result := 1
1839 Else Result := 0;
1840 End
1841 Else AccessError('Float');
1842End;
1843
1844Procedure TBooleanField.SetAsFloat(Const NewValue:Extended);
1845Begin
1846 SetAsInteger(round(NewValue));
1847End;
1848
1849Function TBooleanField.GetAsInteger:LongInt;
1850Begin
1851 If FValue<>Nil Then
1852 Begin
1853 If Boolean(FValue^) Then Result := 1
1854 Else Result := 0;
1855 End
1856 Else AccessError('Integer');
1857End;
1858
1859Procedure TBooleanField.SetAsInteger(NewValue:LongInt);
1860Begin
1861 If NewValue = 0 Then SetAsBoolean(False)
1862 Else SetAsBoolean(True);
1863End;
1864
1865
1866{
1867ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1868º º
1869º Speed-Pascal/2 Version 2.0 º
1870º º
1871º Speed-Pascal Component Classes (SPCC) º
1872º º
1873º This section: TFloatField Class Implementation º
1874º º
1875º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1876º º
1877ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1878}
1879
1880Constructor TFloatField.Create;
1881Begin
1882 Inherited Create;
1883
1884 FPrecision := -1;
1885End;
1886
1887Function TFloatField.GetAsVariant:Variant;
1888Begin
1889 Result:=GetAsFloat;
1890End;
1891
1892Procedure TFloatField.SetAsVariant(NewValue:Variant);
1893Begin
1894 SetAsFloat(NewValue);
1895End;
1896
1897
1898Procedure TFloatField.SetPrecision(Value:Longint);
1899Begin
1900 //If Value < 2 Then Value := 2;
1901 If Value > 15 Then Value := 15;
1902 FPrecision := Value;
1903End;
1904
1905
1906Function TFloatField.GetAsString:String;
1907Var E:Extended;
1908Begin
1909 If FValue <> Nil Then
1910 Begin
1911 E := GetAsFloat;
1912
1913 If Precision >= 0 Then
1914 Begin
1915 Result := Format('%.'+ tostr(Precision) +'f',[E]);
1916 If Precision = 0 Then
1917 If pos('.',Result) > 0 Then SubStr(Result,1,pos('.',Result)-1);
1918 End
1919 Else Result := FloatToStr(E);
1920 End
1921 Else Result := '';
1922End;
1923
1924
1925Procedure TFloatField.SetAsString(Const NewValue:String);
1926Var E:Extended;
1927 C:Integer;
1928 p:Integer;
1929 aValue:String;
1930Begin
1931 If NewValue <> '' Then
1932 Begin
1933 //replace , by .
1934 p := pos(',',NewValue);
1935 If p > 0 Then
1936 Begin
1937 aValue := NewValue;
1938 aValue[p] := '.';
1939 Val(aValue,E,C);
1940 End
1941 Else Val(NewValue,E,C);
1942
1943 If C=0 Then SetAsFloat(E)
1944 Else AccessError('String');
1945 End
1946 Else Clear;
1947End;
1948
1949
1950Function TFloatField.GetAsAnsiString:AnsiString;
1951Begin
1952 Result:=GetAsString;
1953End;
1954
1955Procedure TFloatField.SetAsAnsiString(NewValue:AnsiString);
1956Begin
1957 SetAsString(NewValue);
1958End;
1959
1960Function TFloatField.GetAsFloat:Extended;
1961Begin
1962 If FValue<>Nil Then
1963 Begin
1964 Case FSize Of
1965 4:Result:=Single(FValue^);
1966 8:Result:=Double(FValue^);
1967 10:Result:=Extended(FValue^);
1968 Else AccessError('Float');
1969 End; {Case}
1970 End
1971 //Else AccessError('Float');
1972 Else Result := 0;
1973End;
1974
1975
1976Procedure TFloatField.SetAsFloat(Const NewValue:Extended);
1977Var E:Extended;
1978 S:Single;
1979 D:Double;
1980Begin
1981 Case FSize Of
1982 4:
1983 Begin
1984 S:=NewValue;
1985 SetNewValue(S,SizeOf(Single));
1986 End;
1987 8:
1988 Begin
1989 D:=NewValue;
1990 SetNewValue(D,SizeOf(Double));
1991 End;
1992 10:
1993 Begin
1994 E:=NewValue;
1995 SetNewValue(E,SizeOf(Extended));
1996 End;
1997 End;
1998End;
1999
2000
2001Function TFloatField.GetAsInteger:LongInt;
2002Begin
2003 Result := Round(GetAsFloat);
2004End;
2005
2006
2007Procedure TFloatField.SetAsInteger(NewValue:LongInt);
2008Var E:Extended;
2009Begin
2010 E := NewValue;
2011 SetAsFloat(E);
2012End;
2013
2014{
2015ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2016º º
2017º Speed-Pascal/2 Version 2.0 º
2018º º
2019º Speed-Pascal Component Classes (SPCC) º
2020º º
2021º This section: TCurrencyField Class Implementation º
2022º º
2023º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2024º º
2025ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2026}
2027
2028Constructor TCurrencyField.Create;
2029Begin
2030 Inherited Create;
2031
2032 FPrecision := 2;
2033End;
2034
2035
2036{
2037ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2038º º
2039º Speed-Pascal/2 Version 2.0 º
2040º º
2041º Speed-Pascal Component Classes (SPCC) º
2042º º
2043º This section: TDateField Class Implementation º
2044º º
2045º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2046º º
2047ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2048}
2049
2050Function TDateField.GetAsString:String;
2051Var date:TDateTime;
2052Begin
2053 If FValue <> Nil Then
2054 Begin
2055 date := GetAsDateTime;
2056 DateTimeToString(result,DisplayFormat,date);
2057 End
2058 Else Result := '';
2059End;
2060
2061Destructor TDateField.Destroy;
2062Begin
2063 AssignStr(FDisplayFormat,'');
2064 Inherited Destroy;
2065End;
2066
2067Function TDateField.GetDisplayFormat:String;
2068Begin
2069 If FDisplayFormat=Nil Then Result:=ShortDateFormat
2070 Else Result:=FDisplayFormat^;
2071End;
2072
2073Procedure TDateField.SetDisplayFormat(Const NewValue:String);
2074Begin
2075 AssignStr(FDisplayFormat,NewValue);
2076 If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged);
2077End;
2078
2079Function TDateField.GetAsVariant:Variant;
2080Begin
2081 Result:=GetAsDateTime;
2082End;
2083
2084Procedure TDateField.SetAsVariant(NewValue:Variant);
2085Begin
2086 SetAsDateTime(NewValue);
2087End;
2088
2089
2090Procedure TDateField.SetAsString(Const NewValue:String);
2091Var dt:TDateTime;
2092 Valid:Boolean;
2093Begin
2094 If NewValue <> '' Then
2095 Begin
2096 Try
2097 dt:=StrToDate(NewValue);
2098 Valid:=True;
2099 Except
2100 Valid:=False;
2101 End;
2102 If Valid Then SetAsDateTime(dt);
2103 End
2104 Else Clear;
2105End;
2106
2107Function TDateField.GetAsAnsiString:AnsiString;
2108Begin
2109 Result:=GetAsString;
2110End;
2111
2112Procedure TDateField.SetAsAnsiString(NewValue:AnsiString);
2113Begin
2114 SetAsString(NewValue);
2115End;
2116
2117Function TDateField.GetAsFloat:Extended;
2118Begin
2119 If FValue<>Nil Then Result:=GetAsDateTime
2120 Else AccessError('Float');
2121End;
2122
2123
2124Function TDateField.GetAsDateTime:TDateTime;
2125Var date:TODBCDate;
2126Begin
2127 If FValue<>Nil Then
2128 Begin
2129 date:=TODBCDate(FValue^);
2130 Result:=EncodeDate(date.Year,date.Month,date.Day);
2131 End
2132 Else AccessError('DateTime');
2133End;
2134
2135Procedure TDateField.SetAsDateTime(NewValue:TDateTime);
2136Var R:TODBCDate;
2137Begin
2138 DecodeDate(NewValue,R.Year,R.Month,R.Day);
2139 SetNewValue(R,SizeOf(R));
2140End;
2141
2142{
2143ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2144º º
2145º Speed-Pascal/2 Version 2.0 º
2146º º
2147º Speed-Pascal Component Classes (SPCC) º
2148º º
2149º This section: TTimeField Class Implementation º
2150º º
2151º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2152º º
2153ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2154}
2155
2156
2157Procedure RoundDecodeTime(Time: TDateTime; Var Hour, Min, Sec: Word);
2158Var MSec:Word;
2159Begin
2160 DecodeTime(Time, Hour, Min, Sec, MSec);
2161
2162 If MSec > 500 Then
2163 Begin
2164 MSec := 0;
2165 inc(Sec);
2166 End;
2167 If Sec >= 60 Then
2168 Begin
2169 dec(Sec,60);
2170 inc(Min);
2171 End;
2172 If Min >= 60 Then
2173 Begin
2174 dec(Min,60);
2175 inc(Hour);
2176 End;
2177End;
2178
2179
2180Destructor TTimeField.Destroy;
2181Begin
2182 AssignStr(FDisplayFormat,'');
2183 Inherited Destroy;
2184End;
2185
2186Function TTimeField.GetDisplayFormat:String;
2187Begin
2188 If FDisplayFormat=Nil Then Result:=LongTimeFormat
2189 Else Result:=FDisplayFormat^;
2190End;
2191
2192Procedure TTimeField.SetDisplayFormat(Const NewValue:String);
2193Begin
2194 AssignStr(FDisplayFormat,NewValue);
2195 If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged);
2196End;
2197
2198Function TTimeField.GetAsVariant:Variant;
2199Begin
2200 Result:=GetAsDateTime;
2201End;
2202
2203Procedure TTimeField.SetAsVariant(NewValue:Variant);
2204Begin
2205 SetAsDateTime(NewValue);
2206End;
2207
2208
2209Function TTimeField.GetAsString:String;
2210Var Time:TDateTime;
2211Begin
2212 If FValue<>Nil Then
2213 Begin
2214 Time:=GetAsDateTime;
2215 DateTimeToString(Result,DisplayFormat,Time);
2216 End
2217 Else Result:='';
2218End;
2219
2220Procedure TTimeField.SetAsString(Const NewValue:String);
2221Var dt:TDateTime;
2222 Valid:Boolean;
2223Begin
2224 If NewValue <> '' Then
2225 Begin
2226 Try
2227 dt:=StrToTime(NewValue);
2228 Valid:=True;
2229 Except
2230 Valid:=False;
2231 End;
2232 If Valid Then SetAsDateTime(dt);
2233 End
2234 Else Clear;
2235End;
2236
2237Function TTimeField.GetAsAnsiString:AnsiString;
2238Begin
2239 Result:=GetAsString;
2240End;
2241
2242Procedure TTimeField.SetAsAnsiString(NewValue:AnsiString);
2243Begin
2244 SetAsString(NewValue);
2245End;
2246
2247Function TTimeField.GetAsFloat:Extended;
2248Begin
2249 If FValue<>Nil Then Result:=GetAsDateTime
2250 Else AccessError('Float');
2251End;
2252
2253
2254Function TTimeField.GetAsDateTime:TDateTime;
2255Var Time:TODBCTime;
2256Begin
2257 If FValue<>Nil Then
2258 Begin
2259 Time:=TODBCTime(FValue^);
2260 Result:=EncodeTime(Time.Hour,Time.Minute,Time.Second,0);
2261 End
2262 Else AccessError('DateTime');
2263End;
2264
2265Procedure TTimeField.SetAsDateTime(NewValue:TDateTime);
2266Var R:TODBCTime;
2267Begin
2268 RoundDecodeTime(NewValue,R.Hour,R.Minute,R.Second);
2269 SetNewValue(R,SizeOf(R));
2270End;
2271
2272{
2273ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2274º º
2275º Speed-Pascal/2 Version 2.0 º
2276º º
2277º Speed-Pascal Component Classes (SPCC) º
2278º º
2279º This section: TDateTimeField Class Implementation º
2280º º
2281º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2282º º
2283ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2284}
2285
2286
2287Destructor TDateTimeField.Destroy;
2288Begin
2289 AssignStr(FDisplayFormat,'');
2290 Inherited Destroy;
2291End;
2292
2293Function TDateTimeField.GetDisplayFormat:String;
2294Begin
2295 If FDisplayFormat=Nil Then Result:=ShortDateFormat+' '+LongTimeFormat
2296 Else Result:=FDisplayFormat^;
2297End;
2298
2299Procedure TDateTimeField.SetDisplayFormat(Const NewValue:String);
2300Begin
2301 AssignStr(FDisplayFormat,NewValue);
2302 If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged);
2303End;
2304
2305Function TDateTimeField.GetAsVariant:Variant;
2306Begin
2307 Result:=GetAsDateTime;
2308End;
2309
2310Procedure TDateTimeField.SetAsVariant(NewValue:Variant);
2311Begin
2312 SetAsDateTime(NewValue);
2313End;
2314
2315
2316Function TDateTimeField.GetAsString:String;
2317Var DateTime:TDateTime;
2318Begin
2319 If FValue<>Nil Then
2320 Begin
2321 DateTime:=GetAsDateTime;
2322 DateTimeToString(result,DisplayFormat,DateTime);
2323 End
2324 Else Result:='';
2325End;
2326
2327Procedure TDateTimeField.SetAsString(Const NewValue:String);
2328Var dt:TDateTime;
2329 Valid:Boolean;
2330Begin
2331 If NewValue <> '' Then
2332 Begin
2333 Try
2334 dt:=StrToDateTime(NewValue);
2335 Valid:=True;
2336 Except
2337 Valid:=False;
2338 End;
2339 If Valid Then SetAsDateTime(dt);
2340 End
2341 Else Clear;
2342End;
2343
2344Function TDateTimeField.GetAsAnsiString:AnsiString;
2345Begin
2346 Result:=GetAsString;
2347End;
2348
2349Procedure TDateTimeField.SetAsAnsiString(NewValue:AnsiString);
2350Begin
2351 SetAsString(NewValue);
2352End;
2353
2354Function TDateTimeField.GetAsFloat:Extended;
2355Begin
2356 If FValue<>Nil Then Result:=GetAsDateTime
2357 Else AccessError('Float');
2358End;
2359
2360Function TDateTimeField.GetAsDateTime:TDateTime;
2361Var dt:TODBCDateTime;
2362Begin
2363 If FValue<>Nil Then
2364 Begin
2365 dt:=TODBCDateTime(FValue^);
2366 Result:=EncodeDate(dt.Date.Year,dt.Date.Month,dt.Date.Day) +
2367 EncodeTime(dt.Time.Hour,dt.Time.Minute,dt.Time.Second,0);
2368 End
2369 Else AccessError('DateTime');
2370End;
2371
2372Procedure TDateTimeField.SetAsDateTime(NewValue:TDateTime);
2373Var R:TODBCDateTime;
2374Begin
2375 DecodeDate(NewValue,R.Date.Year,R.Date.Month,R.Date.Day);
2376 RoundDecodeTime(NewValue,R.Time.Hour,R.Time.Minute,R.Time.Second);
2377 SetNewValue(R,SizeOf(R));
2378End;
2379
2380{
2381ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2382º º
2383º Speed-Pascal/2 Version 2.0 º
2384º º
2385º Speed-Pascal Component Classes (SPCC) º
2386º º
2387º This section: TBlobField Class Implementation º
2388º º
2389º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2390º º
2391ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2392}
2393
2394Function TBlobField.GetAsString:String;
2395Begin
2396 If FValue <> Nil Then Result := '[Blob]'
2397 Else Result := '[BLOB]';
2398End;
2399
2400Function TBlobField.GetAsAnsiString:AnsiString;
2401Begin
2402 Result := GetAsString;
2403End;
2404
2405Procedure TBlobField.LoadFromStream(Stream:TStream);
2406Var prec:^Byte;
2407Begin
2408 If Stream Is TStream Then
2409 Begin
2410 GetMem(prec, Stream.Size);
2411 Stream.Position := 0;
2412 Stream.Read(prec^,Stream.Size);
2413 SetAsValue(prec^, Stream.Size);
2414 FreeMem(prec, Stream.Size);
2415 End;
2416End;
2417
2418{
2419ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2420º º
2421º Speed-Pascal/2 Version 2.0 º
2422º º
2423º Speed-Pascal Component Classes (SPCC) º
2424º º
2425º This section: TMemoField Class Implementation º
2426º º
2427º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2428º º
2429ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2430}
2431
2432Function TMemoField.GetAsString:String;
2433Begin
2434 If FValue <> Nil Then Result := '[Memo]'
2435 Else Result := '[MEMO]';
2436End;
2437
2438Function TMemoField.GetAsAnsiString:AnsiString;
2439Begin
2440 If FValue = Nil Then Result := ''
2441 Else Result := PChar(FValue)^;
2442End;
2443
2444Procedure TMemoField.SetAsAnsiString(NewValue:AnsiString);
2445Begin
2446 If NewValue <> '' Then
2447 Begin
2448 SetNewValue(PChar(NewValue)^,length(PChar(NewValue)^)+1);
2449 End
2450 Else Clear;
2451End;
2452
2453{
2454ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2455º º
2456º Speed-Pascal/2 Version 2.0 º
2457º º
2458º Speed-Pascal Component Classes (SPCC) º
2459º º
2460º This section: TGraphicField Class Implementation º
2461º º
2462º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2463º º
2464ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2465}
2466
2467Function TGraphicField.GetAsString:String;
2468Begin
2469 If FValue<>Nil Then Result:='[Graphic]'
2470 Else Result:='[GRAPHIC]';
2471End;
2472
2473{
2474ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2475º º
2476º Speed-Pascal/2 Version 2.0 º
2477º º
2478º Speed-Pascal Component Classes (SPCC) º
2479º º
2480º This section: TFieldList Class Implementation º
2481º º
2482º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2483º º
2484ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2485}
2486
2487Procedure TFieldList.Clear;
2488Var T:LongInt;
2489 field:TField;
2490Begin
2491 For T:=0 To Count-1 Do
2492 Begin
2493 field:=Items[T];
2494 field.Destroy;
2495 End;
2496 Inherited Clear;
2497End;
2498
2499
2500
2501{
2502ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2503º º
2504º Speed-Pascal/2 Version 2.0 º
2505º º
2506º Speed-Pascal Component Classes (SPCC) º
2507º º
2508º This section: TIndexDef Class Implementation º
2509º º
2510º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2511º º
2512ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2513}
2514
2515Function TIndexDef.GetName:String;
2516Begin
2517 If FName<>Nil Then Result:=FName^
2518 Else Result:='';
2519End;
2520
2521Function TIndexDef.GetFields:String;
2522Begin
2523 If FFields<>Nil Then Result:=FFields^
2524 Else Result:='';
2525End;
2526
2527Constructor TIndexDef.Create(Owner:TIndexDefs;Const Name, Fields:String;Options:TIndexOptions);
2528Begin
2529 Inherited Create;
2530
2531 If Owner <> Nil Then
2532 Begin
2533 Owner.FItems.Add(Self);
2534 FOwner:=Owner;
2535 End;
2536
2537 AssignStr(FName,Name);
2538 AssignStr(FFields,Fields);
2539 FOptions:=Options;
2540End;
2541
2542Destructor TIndexDef.Destroy;
2543Begin
2544 If FOwner <> Nil Then FOwner.FItems.Remove(Self);
2545
2546 AssignStr(FName,'');
2547 AssignStr(FFields,'');
2548
2549 Inherited Destroy;
2550End;
2551
2552{
2553ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2554º º
2555º Speed-Pascal/2 Version 2.0 º
2556º º
2557º Speed-Pascal Component Classes (SPCC) º
2558º º
2559º This section: TIndexDefs Class Implementation º
2560º º
2561º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2562º º
2563ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2564}
2565
2566Function TIndexDefs.GetCount:LongInt;
2567Begin
2568 Result:=FItems.Count;
2569End;
2570
2571Function TIndexDefs.GetItem(Index:LongInt):TIndexDef;
2572Begin
2573 Result:=TIndexDef(FItems[Index]);
2574End;
2575
2576Constructor TIndexDefs.Create(DataSet:TDataSet);
2577Begin
2578 Inherited Create;
2579 FDataSet:=DataSet;
2580 FItems.Create;
2581End;
2582
2583Destructor TIndexDefs.Destroy;
2584Begin
2585 Clear;
2586 FItems.Destroy;
2587 Inherited Destroy;
2588End;
2589
2590Procedure TIndexDefs.Clear;
2591Var IndexDef:TIndexDef;
2592Begin
2593 While FItems.Count > 0 Do
2594 Begin
2595 IndexDef := TIndexDef(FItems[0]);
2596 IndexDef.Destroy; // auto removing from FItems
2597 End;
2598End;
2599
2600Function TIndexDefs.Add(Const Name,Fields:String;Options:TIndexOptions):TIndexDef;
2601Begin
2602 //...check valid
2603 Result.Create(Self, Name, Fields,Options);
2604End;
2605
2606Procedure TIndexDefs.Assign(IndexDefs: TIndexDefs);
2607Var IndexDef:TIndexDef;
2608 t:LongInt;
2609Begin
2610 Clear;
2611 For t:=0 To IndexDefs.Count-1 Do
2612 Begin
2613 IndexDef:=IndexDefs.Items[t];
2614 Add(IndexDef.Name,IndexDef.Fields,IndexDef.Options);
2615 End;
2616End;
2617
2618Function TIndexDefs.FindIndexForFields(Const Fields:String):TIndexDef;
2619Begin
2620 Result:=GetIndexForFields(Fields,False);
2621 If Result=Nil Then DataBaseError('No index for fields: '+Fields);
2622End;
2623
2624Function TIndexDefs.GetIndexForFields(Const Fields:String;CaseInsensitive:Boolean):TIndexDef;
2625Var t:LongInt;
2626 s,s1:String;
2627Begin
2628 s:=Fields;
2629 If CaseInsensitive Then UpcaseStr(s);
2630 Result:=Nil;
2631 For t:=0 To Count-1 Do
2632 Begin
2633 s1:=Items[t].Fields;
2634 If CaseInsensitive Then UpcaseStr(s1);
2635 If s=s1 Then
2636 Begin
2637 Result:=Items[t];
2638 exit;
2639 End;
2640 End;
2641End;
2642
2643Function TIndexDefs.IndexOf(Const Name:String):LongInt;
2644Var t:LongInt;
2645Begin
2646 Result:=-1;
2647 For t:=0 To Count-1 Do If Items[t].Name=Name Then
2648 Begin
2649 Result:=t;
2650 exit;
2651 End;
2652End;
2653
2654Procedure TIndexDefs.Update;
2655Begin
2656 TTable(FDataSet).UpdateIndexDefs;
2657End;
2658
2659{
2660ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2661º º
2662º Speed-Pascal/2 Version 2.0 º
2663º º
2664º Speed-Pascal Component Classes (SPCC) º
2665º º
2666º This section: TFieldDef Class Implementation º
2667º º
2668º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2669º º
2670ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2671}
2672
2673Constructor TFieldDef.Create(aOwner:TFieldDefs; Const aName:String;
2674 aDataType:TFieldType; aSize:Longword; aRequired:Boolean; aFieldNo:Longint);
2675Begin
2676 Inherited Create;
2677
2678 If aOwner <> Nil Then
2679 Begin
2680 aFieldNo := aOwner.FItems.Add(Self);
2681 FOwner := aOwner;
2682 End;
2683
2684 FName := aName;
2685 FDataType := aDataType;
2686 FSize := aSize;
2687 If aDataType = ftString Then Inc(FSize);
2688 FRequired := aRequired;
2689 FFieldNo := aFieldNo;
2690 FPrecision := -1;
2691 If FDataType In [ftWord,ftInteger,ftSmallInt] Then
2692 If not (FSize In [1,2,4]) Then FSize:=4; //LongInt
2693 If FDataType=ftFloat Then
2694 If not (FSize In [4,8,10]) Then FSize:=10; //Extended
2695 FFields.Create;
2696End;
2697
2698Function TFieldDef.GetTypeName:String;
2699Begin
2700 If FTypeName=Nil Then
2701 Begin
2702 Result:='';
2703 If FOwner.FDataSet Is TTable Then
2704 Result:=TTable(FOwner.FDataSet).DataType2Name(FDataType);
2705 End
2706 Else Result:=FTypeName^;
2707End;
2708
2709Procedure TFieldDef.SetTypeName(Const NewValue:String);
2710Begin
2711 AssignStr(FTypeName,NewValue);
2712End;
2713
2714Destructor TFieldDef.Destroy;
2715Var i:Longint;
2716 Field:TField;
2717Begin
2718 If FOwner <> Nil Then FOwner.FItems.Remove(Self);
2719
2720 If FFields <> Nil Then
2721 Begin
2722 For i := 0 To FFields.Count-1 Do
2723 Begin
2724 Field := TField(FFields[i]);
2725 If Field <> Nil Then Field.Destroy;
2726 End;
2727 End;
2728
2729 AssignStr(FForeignKey,'');
2730 AssignStr(FTypeName,'');
2731
2732 FFields.Destroy;
2733 FFields := Nil;
2734
2735 Inherited Destroy;
2736End;
2737
2738
2739Function TFieldDef.CreateField(Owner:TComponent):TField;
2740Var FieldClass:TFieldClass;
2741Begin
2742 FieldClass := GetFieldClass;
2743 If FieldClass = Nil Then DatabaseError('Unknown field type "'+Name+'"');
2744
2745 Result := FieldClass.Create;
2746 Try
2747 Result.FFieldDef := Self;
2748 Result.FRequired := Required;
2749 Result.FSize := Size;
2750 Result.FDataType := FDataType;
2751 If Result Is TFloatField Then
2752 Begin
2753 TFloatField(Result).FPrecision := Precision;
2754 If not (Size In [4,8]) Then
2755 Begin
2756 Size:=8;
2757 Result.FSize:=8;
2758 End;
2759 End;
2760 If FOwner <> Nil Then Result.FDataSet := FOwner.FDataSet;
2761 GetMem(Result.FValue,Size);
2762 Result.FValueLen := Size;
2763 Except;
2764 Result.Free;
2765 Raise;
2766 End;
2767End;
2768
2769
2770Function TFieldDef.GetFieldClass:TFieldClass;
2771Begin
2772 Result := FOwner.FDataSet.GetFieldClass(FDataType);
2773End;
2774
2775
2776Function TFieldDef.GetPrimaryKey:Boolean;
2777Var Keys:TStrings;
2778 t:LongInt;
2779Begin
2780 If (Not (FOwner.FDataSet.IsTable)) Then
2781 DataBaseError('Cannot perform this action on a query or stored procedure');
2782
2783 Result:=False;
2784 If FOwner.FDataSet.Active Then
2785 Begin
2786 Keys.Create;
2787 TTable(FOwner.FDataSet).GetPrimaryKeys(Keys);
2788 For t:=0 To Keys.Count-1 Do
2789 If Keys[t]=Name Then
2790 Begin
2791 Keys.Destroy;
2792 Result:=True;
2793 exit;
2794 End;
2795 Keys.Destroy;
2796 End
2797 Else Result:=FPrimaryKey;
2798End;
2799
2800Procedure TFieldDef.SetPrimaryKey(NewValue:Boolean);
2801Begin
2802 If (Not (FOwner.FDataSet.IsTable)) Then
2803 DataBaseError('Cannot perform this action on a query or stored procedure');
2804
2805 FPrimaryKey:=NewValue;
2806 If FOwner.FDataSet.Active Then //Modify table definition
2807 Begin
2808 End;
2809End;
2810
2811Function TFieldDef.GetForeignKey:String;
2812Var Keys:TStrings;
2813 t:LongInt;
2814 s:String;
2815Begin
2816 If (Not (FOwner.FDataSet.IsTable)) Then
2817 DataBaseError('Cannot perform this action on a query or stored procedure');
2818
2819 If FOwner.FDataSet.Active Then
2820 Begin
2821 Keys.Create;
2822 TTable(FOwner.FDataSet).GetForeignKeys(Keys);
2823 For t:=0 To Keys.Count-1 Do
2824 Begin
2825 s:=Keys[t];
2826 If Pos('>',s)<>0 Then s[0]:=chr(pos('>',s)-1);
2827 If s=Name Then
2828 Begin
2829 Keys.Destroy;
2830 s:=Keys[t];
2831 Delete(s,1,pos('>',s));
2832 Result:=s;
2833 exit;
2834 End;
2835 End;
2836 Keys.Destroy;
2837 End
2838 Else
2839 Begin
2840 If FForeignKey<>Nil Then Result:=FForeignKey^
2841 Else Result:='';
2842 End;
2843End;
2844
2845Procedure TFieldDef.SetForeignKey(Const NewValue:String);
2846Begin
2847 If (Not (FOwner.FDataSet.IsTable)) Then
2848 DataBaseError('Cannot perform this action on a query or stored procedure');
2849
2850 AssignStr(FForeignKey,NewValue);
2851 If FOwner.FDataSet.Active Then //modify table definition
2852 Begin
2853 End;
2854End;
2855
2856{
2857ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2858º º
2859º Speed-Pascal/2 Version 2.0 º
2860º º
2861º Speed-Pascal Component Classes (SPCC) º
2862º º
2863º This section: TFieldDefs Class Implementation º
2864º º
2865º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2866º º
2867ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2868}
2869
2870Constructor TFieldDefs.Create(DataSet:TDataSet);
2871Begin
2872 Inherited Create;
2873
2874 FDataSet := DataSet;
2875 FItems.Create;
2876End;
2877
2878
2879Destructor TFieldDefs.Destroy;
2880Begin
2881 Clear;
2882 FItems.Destroy;
2883
2884 Inherited Destroy;
2885End;
2886
2887
2888Function TFieldDefs.Rows:LongInt;
2889Var FieldDef:TFieldDef;
2890Begin
2891 Result := 0;
2892 If Count = 0 Then Exit;
2893 FieldDef := Items[0];
2894 Result := FieldDef.Fields.Count;
2895End;
2896
2897
2898Procedure TFieldDefs.Clear;
2899Var FieldDef:TFieldDef;
2900Begin
2901 While FItems.Count > 0 Do
2902 Begin
2903 FieldDef := TFieldDef(FItems[0]);
2904 FieldDef.Destroy; // auto removing from FItems
2905 End;
2906End;
2907
2908
2909Function TFieldDefs.GetCount:Longint;
2910Begin
2911 Result := FItems.Count;
2912End;
2913
2914
2915Function TFieldDefs.GetItem(Index:Longint):TFieldDef;
2916Begin
2917 Result := FItems[Index];
2918End;
2919
2920
2921Function TFieldDefs.Add(Const Name:String; DataType:TFieldType; Size:Longint; Required:Boolean):TFieldDef;
2922Begin
2923 //...check valid
2924 Result.Create(Self, Name, DataType, Size, Required, FItems.Count);
2925End;
2926
2927Procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
2928Var FieldDef:TFieldDef;
2929 t:LongInt;
2930Begin
2931 Clear;
2932 For t:=0 To FieldDefs.Count-1 Do
2933 Begin
2934 FieldDef:=Items[t];
2935 Add(FieldDef.Name,FieldDef.DataType,FieldDef.Size,FieldDef.Required);
2936 End;
2937End;
2938
2939Function TFieldDefs.Find(const Name: string): TFieldDef;
2940Var Index:LongInt;
2941Begin
2942 Index:=IndexOf(Name);
2943 If Index=-1 Then SQLError('Field not found: '+Name)
2944 Else Result:=Items[Index];
2945End;
2946
2947Function TFieldDefs.IndexOf(const Name: string): LongInt;
2948Var t:LongInt;
2949Begin
2950 Result:=-1;
2951 For t:=0 To Count-1 Do If Items[t].Name=Name Then
2952 Begin
2953 Result:=t;
2954 exit;
2955 End;
2956End;
2957
2958Procedure TFieldDefs.Update;
2959Begin
2960 FDataSet.QueryTable;
2961End;
2962
2963{
2964ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2965º º
2966º Speed-Pascal/2 Version 2.0 º
2967º º
2968º Speed-Pascal Component Classes (SPCC) º
2969º º
2970º This section: TDataSet Class Implementation º
2971º º
2972º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2973º º
2974ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2975}
2976
2977Const
2978 DefaultFieldClasses:Array[TFieldType] Of TFieldClass=
2979 (TBlobField, {ftUnknown}
2980 TStringField, {ftString}
2981 TSmallintField, {ftSmallInt}
2982 TIntegerField, {ftInteger}
2983 TBlobField, {ftWord}
2984 TBlobField, {ftBoolean}
2985 TFloatField, {ftFloat}
2986 TCurrencyField, {ftCurrency}
2987 TBlobField, {ftBCD}
2988 TDateField, {ftDate}
2989 TTimeField, {ftTime}
2990 TDateTimeField, {ftDateTime}
2991 TBlobField, {ftBytes}
2992 TBlobField, {ftVarBytes}
2993 TAutoIncField, {ftAutoInc}
2994 TBlobField, {ftBlob}
2995 TMemoField, {ftMemo}
2996 TGraphicField, {ftGraphic}
2997 TMemoField, {ftFmtMemo}
2998 TBlobField, {ftTypedBinary}
2999 TBlobField {ftOLE}
3000 );
3001
3002
3003Procedure TDataSet.SetupComponent;
3004Begin
3005 Include(ComponentState, csHandleLinks);
3006
3007 AssignStr(FDataBase,'');
3008 AssignStr(FServer,'');
3009
3010 Inherited SetupComponent;
3011
3012 Name:='DataSet';
3013 FFieldDefs.Create(Self);
3014 FSelect:=TStringList.Create;
3015 FCurrentRow:=-1;
3016 FCurrentField:=0;
3017End;
3018
3019Destructor TDataSet.Destroy;
3020Begin
3021 FFieldDefs.Destroy;
3022 FFieldDefs:=Nil;
3023 AssignStr(FServer,'');
3024 AssignStr(FDataBase,'');
3025 FSelect.Destroy;
3026 FSelect:=Nil;
3027
3028 Inherited Destroy;
3029End;
3030
3031
3032Function TDataSet.GetFieldClass(FieldType:TFieldType):TFieldClass;
3033Begin
3034 Result := DefaultFieldClasses[FieldType];
3035End;
3036
3037
3038Procedure TDataSet.DesignerNotification(Var DNS:TDesignerNotifyStruct);
3039Var AForm:TForm;
3040Begin
3041 AForm := TForm(Owner);
3042 If AForm <> Nil Then
3043 Begin
3044 While (AForm.Designed) And (AForm.Owner <> Nil) Do
3045 Begin
3046 AForm := TForm(AForm.Owner);
3047 End;
3048 End;
3049 If AForm <> Nil Then
3050 If AForm Is TForm Then AForm.DesignerNotification(DNS);
3051End;
3052
3053
3054Function TDataSet.Locate(Const KeyFields:String;Const KeyValues:Array Of Const;
3055 Options:TLocateOptions):Boolean;
3056Begin
3057 Result := False;
3058 //???
3059End;
3060
3061
3062Procedure TDataSet.SetFieldDefs(NewValue:TFieldDefs);
3063Begin
3064 FFieldDefs.Assign(NewValue);
3065End;
3066
3067
3068Procedure TDataSet.GetStoredProcNames(List:TStrings);
3069Begin
3070 List.Clear;
3071End;
3072
3073
3074Procedure TDataSet.Open;
3075Begin
3076 Active := True;
3077End;
3078
3079
3080Procedure TDataSet.Close;
3081Begin
3082 Active := False;
3083End;
3084
3085
3086Procedure TDataSet.SetActive(NewValue:Boolean);
3087Begin
3088 If FActive <> NewValue Then
3089 Begin
3090 FActive := NewValue;
3091 DataChange(deDataBaseChanged);
3092 End;
3093End;
3094
3095
3096Procedure TDataSet.SetCurrentRow(NewValue:LongInt);
3097Begin
3098 MoveBy(NewValue-FCurrentRow);
3099End;
3100
3101
3102Procedure TDataSet.SetCurrentField(NewValue:LongInt);
3103Begin
3104 If NewValue<0 Then NewValue:=0;
3105 If NewValue>FieldCount-1 Then NewValue:=FieldCount-1;
3106 FCurrentField:=NewValue;
3107End;
3108
3109
3110Function TDataSet.GetEOF:Boolean;
3111Begin
3112 Result := GetResultColRow(0,FCurrentRow+1) = Nil;
3113End;
3114
3115
3116Function TDataSet.GetBOF:Boolean;
3117Begin
3118 Result := FCurrentRow <= 0;
3119End;
3120
3121
3122Function TDataSet.GetMaxRows:LongInt;
3123Begin
3124 Result := FMaxRows;
3125 If RowInserted Then inc(Result);
3126End;
3127
3128
3129Procedure TDataSet.Refresh;
3130Begin
3131 DataChange(deDataBaseChanged);
3132End;
3133
3134
3135Procedure TDataSet.DataChange(event:TDataChange);
3136Var I:LongInt;
3137 Source:TDataSource;
3138 FLinkList:TList;
3139Begin
3140 If FDataChangeLock Then Exit;
3141
3142 FLinkList:=FreeNotifyList;
3143 If FLinkList<>Nil Then For I:=0 To FLinkList.Count-1 Do
3144 Begin
3145 Source:=FLinkList.Items[I];
3146 If Source Is TDataSource Then
3147 Begin
3148 Source.DataChange(event);
3149 If Source.OnDataChange<>Nil Then Source.OnDataChange(Source,event);
3150 End;
3151 End;
3152End;
3153
3154
3155Procedure TDataSet.First;
3156Begin
3157 SetCurrentRow(0);
3158End;
3159
3160
3161Procedure TDataSet.Last;
3162Begin
3163 SetCurrentRow(MaxRows-1);
3164End;
3165
3166
3167Procedure TDataSet.Next;
3168Begin
3169 SetCurrentRow(FCurrentRow+1);
3170End;
3171
3172
3173Procedure TDataSet.Prior;
3174Begin
3175 SetCurrentRow(FCurrentRow-1);
3176End;
3177
3178
3179Procedure TDataSet.MoveBy(Distance:LongInt);
3180Var Field:TField;
3181 FieldDef:TFieldDef;
3182Begin
3183 If Distance = 0 Then Exit;
3184 If FFieldDefs.Count = 0 Then exit;
3185
3186 If FRowIsInserted Then CommitInsert(True);
3187
3188 FCurrentRow := FCurrentRow + Distance;
3189 If FCurrentRow < 0 Then FCurrentRow := 0;
3190 If FCurrentRow >= MaxRows Then FCurrentRow := MaxRows-1;
3191
3192 Field := GetResultColRow(0,FCurrentRow);
3193
3194 FieldDef := FFieldDefs[0];
3195
3196 If FieldDef <> Nil Then
3197 Begin
3198 If FCurrentRow > FieldDef.Fields.Count-1
3199 Then FCurrentRow := FieldDef.Fields.Count-1;
3200 If FCurrentRow < 0 Then FCurrentRow := 0;
3201 End;
3202
3203 DataChange(dePositionChanged);
3204End;
3205
3206
3207Function TDataSet.WriteSCUResource(Stream:TResourceStream):Boolean;
3208Var S:String;
3209 dll:String;
3210 P,p1:Pointer;
3211 len:LongInt;
3212 dbType:TDBTypes;
3213 dbOrd:LongInt;
3214 DriverName,Advanced,UID:String;
3215Begin
3216 S:=Server;
3217 GetDBServerFromAlias(S,dll,dbType);
3218 dbOrd:=ord(dbType);
3219
3220 len:=Length(S)+1+Length(dll)+1+4;
3221 GetMem(P,len);
3222 p1:=P;
3223 Move(S,p1^,Length(S)+1);
3224 Inc(p1,Length(S)+1);
3225 Move(dll,p1^,Length(dll)+1);
3226 inc(p1,length(dll)+1);
3227 Move(dbOrd,p1^,4);
3228 Result:=Stream.NewResourceEntry(rnDBServer,P^,len);
3229 FreeMem(P,len);
3230 If Not Result Then Exit;
3231
3232 S:=DataBase;
3233 GetDBServerFromDBAlias(S,DriverName,Advanced,UID);
3234 len:=Length(S)+1+Length(Advanced)+1+length(UID)+1;
3235 GetMem(P,len);
3236 p1:=P;
3237 Move(S,p1^,Length(S)+1);
3238 Inc(p1,Length(S)+1);
3239 Move(Advanced,p1^,Length(Advanced)+1);
3240 Inc(p1,Length(Advanced)+1);
3241 Move(UID,p1^,Length(UID)+1);
3242 Result:=Stream.NewResourceEntry(rnDBDataBase,S,Length(S)+1);
3243 FreeMem(P,len);
3244End;
3245
3246
3247Procedure TDataSet.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
3248Var
3249 S,dll:String;
3250 B:^Byte;
3251 dbType:TDBTypes;
3252 Advanced,UID:String;
3253Begin
3254 If ResName = rnDBServer Then
3255 Begin
3256 dbType:=ODBC;
3257
3258 B:=@Data;
3259 Move(B^,S,B^+1);
3260 Inc(B,B^+1);
3261 Move(B^,dll,B^+1);
3262
3263 If DataLen>length(S)+1+length(dll)+1 Then //Sibyl FP3
3264 Begin
3265 inc(B,length(dll)+1);
3266 move(B^,dbType,sizeof(dbType));
3267 End;
3268
3269 AddServerAlias(S,dll,dbType);
3270 Server:=S;
3271 End;
3272
3273 If ResName = rnDBDataBase Then
3274 Begin
3275 Advanced:='';
3276 UID:='';
3277
3278 B:=@Data;
3279 Move(B^,S,B^+1);
3280 Inc(B,B^+1);
3281 If DataLen>length(S)+1 Then //Sibyl FP3
3282 Begin
3283 Move(B^,Advanced,B^+1);
3284 Inc(B,B^+1);
3285 Move(B^,UID,B^+1);
3286 End;
3287
3288 AddDataBaseAlias(S,Server,Advanced,UID);
3289 DataBase:=S;
3290 End;
3291End;
3292
3293
3294Function TDataSet.GetDataBaseName:String;
3295Begin
3296 Result:=FDataBase^;
3297End;
3298
3299
3300Procedure TDataSet.SetDataBaseName(Const NewValue:String);
3301Var Alias,Advanced,UID,DllName:String;
3302 DNS:TDesignerNotifyStruct;
3303Begin
3304 If GetDataBaseName=NewValue Then Exit;
3305
3306 If FOpened Then
3307 If GetDataBaseName<>'' Then
3308 Begin
3309 ErrorBox(LoadNLSStr(SCannotPerformDBAction));
3310 Exit;
3311 End;
3312
3313 AssignStr(FDataBase,NewValue);
3314
3315 FreeDBProcs(FDBProcs);
3316 FDBProcs.DataBase:=NewValue;
3317
3318 GetDBServerFromDBAlias(NewValue,Alias,Advanced,UID);
3319 If Alias<>'' Then If Alias<>Server Then
3320 Begin
3321 AssignStr(FServer, Alias);
3322 FDBProcs.AliasName:=Alias;
3323 End;
3324 If ComponentState*[csReading]=[] Then FDBProcs.UID:=UID
3325 Else If FDBProcs.UID='' Then FDBProcs.UID:=UID;
3326 GetDBServerFromAlias(FDBProcs.AliasName,DllName,FDBProcs.DBType);
3327
3328 Case FDBProcs.DBType Of
3329 Native_mSQL:
3330 Begin
3331 If ComponentState*[csReading]=[] Then FDBProcs.Host:=Advanced
3332 Else If FDBProcs.Host='' Then FDBProcs.Host:=Advanced;
3333 End;
3334 End;
3335
3336 If Self Is TTable Then If ComponentState*[csReading]=[] Then
3337 Begin
3338 TTable(Self).TableName:='';
3339 TTable(Self).UserId:='';
3340 TTable(Self).Password:='';
3341 End;
3342
3343 DNS.Sender := Self;
3344 DNS.Code := dncPropertyUpdate;
3345 DNS.return := 0;
3346 DesignerNotification(DNS);
3347End;
3348
3349
3350Function TDataSet.GetServer:String;
3351Begin
3352 Result:=FServer^;
3353End;
3354
3355
3356Procedure TDataSet.SetServer(Const NewValue:String);
3357Var WasLocked:Boolean;
3358 DllName:String;
3359 DNS:TDesignerNotifyStruct;
3360Begin
3361 If GetServer=NewValue Then Exit;
3362
3363 If FOpened Then
3364 Begin
3365 ErrorBox(LoadNLSStr(SCannotPerformDBAction));
3366 Exit;
3367 End;
3368
3369 FreeDBProcs(FDBProcs);
3370
3371 AssignStr(FServer,NewValue);
3372
3373 FDBProcs.AliasName:=NewValue;
3374 GetDBServerFromAlias(FDBProcs.AliasName,DllName,FDBProcs.DBType);
3375
3376 WasLocked:=FDataSetLocked;
3377 FDataSetLocked:=True;
3378
3379 AssignStr(FDataBase,'');
3380
3381 If Self Is TTable Then AssignStr(TTable(Self).FTableName,'');
3382
3383 FDataSetLocked:=WasLocked;
3384
3385 If ComponentState*[csReading]=[] Then
3386 Begin
3387 FDBProcs.UID:='';
3388 FDBProcs.Host:='';
3389 End;
3390 DNS.Sender := Self;
3391 DNS.Code := dncPropertyUpdate;
3392 DNS.return := 0;
3393 DesignerNotification(DNS);
3394End;
3395
3396
3397Function TDataSet.GetFieldCount:LongInt;
3398Begin
3399 Result:=FFieldDefs.Count;
3400End;
3401
3402
3403Function TDataSet.GetFieldName(Index:LongInt):String;
3404Var FieldDef:TFieldDef;
3405Begin
3406 Result:='';
3407 If ((Index<0)Or(Index>FieldCount-1)) Then Exit;
3408 FieldDef:=FFieldDefs[Index];
3409 Result:=FieldDef.Name;
3410End;
3411
3412
3413Function TDataSet.GetFieldType(Index:LongInt):TFieldType;
3414Var FieldDef:TFieldDef;
3415Begin
3416 Result:=ftUnknown;
3417 If ((Index<0)Or(Index>FieldCount-1)) Then Exit;
3418 FieldDef:=FFieldDefs[Index];
3419 Result:=FieldDef.DataType;
3420End;
3421
3422
3423Function TDataSet.GetFieldFromColumnName(ColumnName:String):TField;
3424Var Index:LongInt;
3425 T:LongInt;
3426 FieldDef:TFieldDef;
3427 S:String;
3428Begin
3429 Result:=Nil;
3430 Index:=-1;
3431 UpcaseStr(ColumnName);
3432 For T:=0 To FFieldDefs.Count-1 Do
3433 Begin
3434 FieldDef:=FFieldDefs[T];
3435 S:=FieldDef.Name;
3436 UpcaseStr(S);
3437 If S=ColumnName Then
3438 Begin
3439 Index:=T;
3440 break;
3441 End;
3442 End;
3443
3444 If Index<>-1 Then Result:=Fields[Index];
3445End;
3446
3447
3448Procedure TDataSet.CheckRequiredFields;
3449Var Field:TField;
3450 i:Longint;
3451Begin
3452 For i := 0 To FieldCount-1 Do
3453 Begin
3454 Field := GetResultColRow(i,FCurrentRow);
3455 If Field<>Nil Then
3456 If Field.Required And Field.IsNull Then
3457 Begin
3458 //Field.FocusControl;
3459 ErrorBox('Field '+ Field.FieldName +' is required');
3460 DatabaseError('Field '+ Field.FieldName +' is required');
3461 End;
3462 End;
3463End;
3464
3465
3466Function TDataSet.GetField(Index:LongInt):TField;
3467Begin
3468 Result:=Nil;
3469 If ((Index<0)Or(Index>FieldCount-1)Or(FCurrentRow<0)) Then Exit;
3470 Result:=GetResultColRow(Index,FCurrentRow);
3471End;
3472
3473
3474Function TDataSet.GetResultColRow(Col,Row:LongInt):TField;
3475Var FieldDef:TFieldDef;
3476Begin
3477 Result := Nil;
3478 If Not FOpened Then Exit;
3479
3480 If Row < 0 Then Exit; //Row does Not exist
3481 If Row >= GetMaxRows Then Exit; //Row does Not exist
3482 If (Col < 0) Or (Col >= FieldDefs.Count) Then Exit; {Column does Not exist}
3483
3484 FieldDef := FieldDefs[Col];
3485 If Row <= FieldDef.Fields.Count-1
3486 Then Result := FieldDef.Fields.Items[Row];
3487End;
3488
3489
3490Procedure TDataSet.AppendRecord(Const values:Array Of Const);
3491Begin
3492 InsertRecord(values);
3493End;
3494
3495
3496Procedure TDataSet.SetFields(Const values:Array Of Const);
3497Var T:LongInt;
3498 rec:TVarRec;
3499 field:TField;
3500Begin
3501 Try
3502 FDataChangeLock:=True;
3503 For T:=0 To High(values) Do
3504 Begin
3505 If T>FieldCount-1 Then Exit;
3506 Field:=Fields[T];
3507 If Field=Nil Then continue;
3508
3509 rec:=TVarRec(values[T]);
3510 Case rec.VType Of
3511 vtInteger:field.AsInteger:=rec.VInteger;
3512 vtBoolean:field.AsBoolean:=rec.VBoolean;
3513 vtChar:field.AsString:=rec.VChar;
3514 vtExtended:field.AsFloat:=rec.VExtended^;
3515 vtString:field.AsString:=rec.VString^;
3516 vtPointer:;
3517 vtPChar:field.AsString:=rec.VPChar^;
3518 vtAnsiString:field.AsString:=AnsiString(rec.VAnsiString);
3519 End; {Case}
3520 End;
3521 Finally
3522 FDataChangeLock:=False;
3523 Post;
3524 End;
3525End;
3526
3527
3528Procedure TDataSet.InsertRecord(Const values:Array Of Const);
3529Begin
3530 Try
3531 FDataChangeLock:=True;
3532 Insert;
3533 Finally
3534 FDataChangeLock:=False;
3535 End;
3536 SetFields(values);
3537End;
3538
3539
3540Function TDataSet.FieldByName(Const FieldName:String):TField;
3541Begin
3542 Result:=FindField(FieldName);
3543 If Result=Nil Then DatabaseError('Field '+FieldName+' not found');
3544End;
3545
3546
3547Function TDataSet.FindFirst:Boolean;
3548Begin
3549 Result:=BOF;
3550End;
3551
3552
3553Function TDataSet.FindLast:Boolean;
3554Begin
3555 Result:=EOF;
3556End;
3557
3558
3559Function TDataSet.FindNext:Boolean;
3560Begin
3561 Result:=not EOF;
3562End;
3563
3564
3565Function TDataSet.FindPrior:Boolean;
3566Begin
3567 Result:=not BOF;
3568End;
3569
3570
3571Function ExtractFieldName(Const Fields:String;Var Pos:LongInt):String;
3572Var t:LongInt;
3573Begin
3574 t:=Pos;
3575 While (t<=Length(Fields))And(Fields[t]<>';') Do Inc(t);
3576 Result:=Copy(Fields,Pos,t-Pos);
3577 If (t<=Length(Fields))And(Fields[t]=';') Then Inc(t);
3578 Pos:=t;
3579End;
3580
3581
3582Procedure TDataSet.GetFieldList(List:TList; const FieldNames: string);
3583Var t:LongInt;
3584Begin
3585 t:=1;
3586 While t<=Length(FieldNames) Do
3587 List.Add(FieldByName(ExtractFieldName(FieldNames,t)));
3588End;
3589
3590
3591Function TDataSet.FindField(Const FieldName:String):TField;
3592Var T:LongInt;
3593 S,s1:String;
3594Begin
3595 Result:=Nil;
3596 S:=FieldName;
3597 UpcaseStr(S);
3598 For T:=0 To FieldCount-1 Do
3599 Begin
3600 s1:=FieldNames[T];
3601 UpcaseStr(s1);
3602 If S=s1 Then
3603 Begin
3604 Result:=Fields[T];
3605 Exit;
3606 End;
3607 End;
3608End;
3609
3610
3611Procedure TDataSet.DoOpen;
3612Begin
3613 FOpened := True;
3614End;
3615
3616
3617Procedure TDataSet.DoClose;
3618Begin
3619 If FRowIsInserted Then CommitInsert(True);
3620 FMaxRows:=0;
3621 FCurrentRow := -1;
3622
3623 FOpened := False;
3624End;
3625
3626
3627Procedure TDataSet.RefreshTable;
3628Begin
3629End;
3630
3631
3632Procedure TDataSet.GetDataSources(List:TStrings);
3633Begin
3634 List.Clear;
3635End;
3636
3637
3638Procedure TDataSet.GetFieldNames(List:TStrings);
3639Var T:LongInt;
3640Begin
3641 List.Clear;
3642
3643 If FieldCount=0 Then
3644 Begin
3645 If ((Designed)And(Not FOpened)) Then
3646 Begin
3647 FActive:=True;
3648 DoOpen;
3649 If Not FOpened Then FActive:=False
3650 Else RefreshTable;
3651 End
3652 Else RefreshTable;
3653 End;
3654
3655 For T:=0 To FieldCount-1 Do List.Add(FieldNames[T]);
3656End;
3657
3658
3659Procedure TDataSet.Delete;
3660Begin
3661 If Not FOpened Then Exit;
3662 If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit;
3663
3664 Try
3665 If FBeforeDelete <> Nil Then FBeforeDelete(Self);
3666
3667 If FRowIsInserted Then CommitInsert(False)
3668 Else DoDelete;
3669
3670 DataChange(deDataBaseChanged);
3671
3672 If FAfterDelete <> Nil Then FAfterDelete(Self);
3673 Except
3674 Raise;
3675 End;
3676End;
3677
3678
3679Procedure TDataSet.DoDelete;
3680Begin
3681 RemoveCurrentFields;
3682End;
3683
3684
3685Procedure TDataSet.Append;
3686Begin
3687 Insert;
3688End;
3689
3690
3691Procedure TDataSet.Insert;
3692Begin
3693 If Not FOpened Then Exit;
3694
3695 Try
3696 If FBeforeInsert <> Nil Then FBeforeInsert(Self);
3697
3698 If FRowIsInserted Then CommitInsert(True);
3699
3700 DoInsert;
3701
3702 DataChange(deDataBaseChanged);
3703
3704 If FAfterInsert <> Nil Then FAfterInsert(Self);
3705 Except
3706 Raise;
3707 End;
3708End;
3709
3710
3711Procedure TDataSet.DoInsert;
3712Begin
3713 If FCurrentRow < 0 Then FCurrentRow := 0; //empty table
3714
3715 InsertCurrentFields;
3716
3717 FRowIsInserted := True;
3718End;
3719
3720
3721Procedure TDataSet.InsertCurrentFields;
3722Var Col,Row:LongInt;
3723 FieldDef:TFieldDef;
3724 Field:TField;
3725Begin
3726 For Col := 0 To FFieldDefs.Count-1 Do
3727 Begin
3728 FieldDef := FFieldDefs[Col];
3729 Field := FieldDef.CreateField(Nil);
3730 //Field.Clear;
3731 If Field.FValue<>Nil Then FreeMem(Field.FValue,Field.FValueLen);
3732 Field.FValue:=Nil;
3733 Field.FValueLen:=0;
3734 Field.FRow := FCurrentRow;
3735 Field.FCol := Col;
3736 FieldDef.Fields.Insert(FCurrentRow,Field);
3737
3738 For Row := FCurrentRow+1 To FieldDef.Fields.Count-1 Do
3739 Begin
3740 Field := FieldDef.Fields[Row];
3741 If Field <> Nil Then Inc(Field.FRow);
3742 End;
3743 End;
3744End;
3745
3746
3747Const Months:Array[1..12] Of String[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul',
3748 'Aug','Sep','Oct','Nov','Dec');
3749
3750Function Field2String(field:TField):String;
3751Var
3752 dt:TDateTime;
3753 Year,Month,Day,Hour,Min,Sec:Word;
3754 s,s1,s2:String;
3755Begin
3756 If field.IsNull Then
3757 Begin
3758 Result:='NULL';
3759 Exit;
3760 End;
3761
3762 Case field.DataType Of
3763 ftDate:
3764 Begin
3765 dt:=field.GetAsDateTime;
3766 DecodeDate(dt,Year,Month,Day);
3767 If Field.FDataSet.FDBProcs.DBType=Native_mSQL Then
3768 Result:=tostr(Day)+'-'+Months[Month]+'-'+tostr(Year)
3769 Else
3770 Result:=tostr(Year)+'-'+tostr(Month)+'-'+tostr(Day);
3771 End;
3772 ftTime:
3773 Begin
3774 dt:=field.GetAsDateTime;
3775 RoundDecodeTime(dt,Hour,Min,Sec);
3776 If Field.FDataSet.FDBProcs.DBType=Native_mSQL Then
3777 Result:=tostr(Hour)+':'+tostr(Min)+':'+tostr(Sec)
3778 Else
3779 Result:=tostr(Hour)+'.'+tostr(Min)+'.'+tostr(Sec);
3780 End;
3781 ftDateTime:
3782 Begin
3783 dt:=field.GetAsDateTime;
3784 DecodeDate(dt,Year,Month,Day);
3785 RoundDecodeTime(dt,Hour,Min,Sec);
3786 If Field.FDataSet.FDBProcs.DBType=Native_Oracle7 Then
3787 Begin
3788 s:=tostr(Year);
3789 While length(s)<4 Do s:='0'+s;
3790 s1:=tostr(Month);
3791 If length(s1)<2 Then s1:='0'+s1;
3792 s2:=tostr(Day);
3793 If length(s2)<2 Then s2:='0'+s2;
3794 Result:='TO_DATE('#39+s+'-'+s1+'-'+s2;
3795 s:=tostr(Hour);
3796 If length(s)<2 Then s:='0'+s;
3797 s1:=tostr(Min);
3798 If length(s1)<2 Then s1:='0'+s1;
3799 s2:=tostr(Sec);
3800 If length(s2)<2 Then s2:='0'+s2;
3801 Result:=Result+' '+s+'.'+s1+'.'+s2;
3802 Result:=Result+#39','#39'YYYY-MM-DD HH24.MI.SS'#39')';
3803 exit;
3804 End
3805 Else
3806 Begin
3807 Result:=tostr(Year)+'-'+tostr(Month)+'-'+tostr(Day);
3808 Result:=Result+'-'+tostr(Hour)+'.'+tostr(Min)+'.';
3809 Result:=Result+tostr(Sec)+'.00';
3810 End;
3811 End;
3812 ftMemo:
3813 Begin
3814 Result:=PChar(Field.FValue)^;
3815 End;
3816 ftFloat:
3817 Begin
3818 Result:=field.AsString;
3819 //eliminate decimal separator
3820 If pos(',',Result)<>0 Then Result[pos(',',Result)]:='.';
3821
3822 End;
3823 Else Result:=field.AsString;
3824 End; {Case}
3825
3826 If Not (field.DataType In [ftSmallInt,ftInteger,ftWord,ftFloat,ftCurrency]) Then
3827 Result:=#39+Result+#39;
3828End;
3829
3830
3831Procedure TDataSet.CommitInsert(Commit:Boolean);
3832Begin
3833End;
3834
3835
3836Procedure TDataSet.RemoveCurrentFields;
3837Var Col,Row:LongInt;
3838 Field:TField;
3839 FieldDef:TFieldDef;
3840Begin
3841 FieldDef := Nil;
3842
3843 For Col := 0 To FFieldDefs.Count-1 Do
3844 Begin
3845 FieldDef := FFieldDefs[Col];
3846 Field := FieldDef.Fields[FCurrentRow];
3847 If Field <> Nil Then
3848 Begin
3849 FieldDef.Fields.Remove(Field);
3850 Field.Destroy;
3851 End;
3852
3853 For Row := FCurrentRow To FieldDef.Fields.Count-1 Do
3854 Begin
3855 Field := FieldDef.Fields[Row];
3856 If Field <> Nil Then Dec(Field.FRow);
3857 End;
3858 End;
3859
3860 If FieldDef <> Nil Then
3861 If FCurrentRow >= FieldDef.Fields.Count
3862 Then FCurrentRow := FieldDef.Fields.Count-1;
3863End;
3864
3865
3866Function TDataSet.UpdateFieldSelect(Field:TField):Boolean;
3867Begin
3868 Result:=False;
3869End;
3870
3871
3872Procedure TDataSet.UpdateField(field:TField;OldValue:Pointer;OldValueLen:LongInt);
3873Begin
3874 If Not FOpened Then Exit;
3875 If FSelect.Count=0 Then Exit; //Nothing To Select
3876 Try
3877 If Not UpdateFieldSelect(field) Then
3878 Begin
3879 FreeMem(field.FValue,field.FValueLen);
3880 field.FValue:=OldValue;
3881 field.FValueLen:=OldValueLen;
3882 End
3883 Else FreeMem(OldValue,OldValueLen);
3884 Except
3885 FreeMem(field.FValue,field.FValueLen);
3886 field.FValue:=OldValue;
3887 field.FValueLen:=OldValueLen;
3888 Raise;
3889 End;
3890End;
3891
3892
3893Procedure TDataSet.Post;
3894Begin
3895 If Not FOpened Then Exit;
3896 If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit;
3897
3898 Try
3899 CheckRequiredFields;
3900
3901 If FBeforePost <> Nil Then FBeforePost(Self);
3902
3903 If FRowIsInserted Then CommitInsert(True)
3904 Else DoPost;
3905
3906 DataChange(deDataBaseChanged);
3907
3908 If FAfterPost <> Nil Then FAfterPost(Self);
3909 Except
3910 Raise;
3911 End;
3912End;
3913
3914
3915Procedure TDataSet.DoPost;
3916Begin
3917End;
3918
3919
3920Procedure TDataSet.Cancel;
3921Begin
3922 If Not FOpened Then Exit;
3923 If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit;
3924
3925 Try
3926 If FBeforeCancel <> Nil Then FBeforeCancel(Self);
3927
3928 If FRowIsInserted Then CommitInsert(False)
3929 Else DoCancel;
3930
3931 DataChange(deDataBaseChanged);
3932
3933 If FAfterCancel <> Nil Then FAfterCancel(Self);
3934 Except
3935 Raise;
3936 End;
3937End;
3938
3939
3940Procedure TDataSet.DoCancel;
3941Begin
3942End;
3943
3944
3945Procedure TDataSet.QueryTable;
3946Begin
3947End;
3948
3949
3950Procedure TDataSet.Loaded;
3951Begin
3952 Inherited Loaded;
3953
3954 If FRefreshOnLoad Then Active:=True;
3955End;
3956
3957
3958Procedure TDataSet.CheckInactive;
3959Begin
3960 If Active Then
3961 Begin
3962 //Close;
3963 DatabaseError('Cannot perform this operation on active dataset !');
3964 End;
3965End;
3966
3967
3968Function TDataSet.IsTable:Boolean;
3969Begin
3970 Result := (Self Is TTable) And (Not (Self Is TQuery)) And (Not (Self Is TStoredProc));
3971End;
3972
3973
3974{
3975ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3976º º
3977º Speed-Pascal/2 Version 2.0 º
3978º º
3979º Speed-Pascal Component Classes (SPCC) º
3980º º
3981º This section: TTable Class Implementation º
3982º º
3983º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
3984º º
3985ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
3986}
3987
3988Procedure TTable.GetPrimaryKeys(List:TStrings);
3989Begin
3990 GetKeys(List,True);
3991End;
3992
3993Function MapODBCType(colType:TFieldType):SQLSMALLINT;
3994Begin
3995 Case colType Of
3996 ftString:Result:=SQL_VARCHAR;
3997 ftCurrency:Result:=SQL_NUMERIC;
3998 ftInteger:Result:=SQL_INTEGER;
3999 ftSmallInt:Result:=SQL_SMALLINT;
4000 ftFloat:Result:=SQL_DOUBLE;
4001 ftDate:Result:=SQL_DATE;
4002 ftTime:Result:=SQL_TIME;
4003 ftDateTime:Result:=SQL_TIMESTAMP;
4004 ftMemo:Result:=SQL_LONGVARCHAR;
4005 ftBlob:Result:=SQL_VARBINARY;
4006 ftGraphic:Result:=SQL_VARGRAPHIC;
4007 Else Result:=SQL_BLOB;
4008 End; {Case}
4009End;
4010
4011Function TTable.DataType2Name(DataType:TFieldType):String;
4012Var List:TStringList;
4013 t:LongInt;
4014Begin
4015 Result:='';
4016
4017 Case FDBProcs.DBType Of
4018 Native_Oracle7:
4019 Begin
4020 Case DataType Of
4021 ftString:Result:='VARCHAR2';
4022 ftSmallInt,ftInteger,ftWord:Result:='INT';
4023 ftBoolean:Result:='CHAR';
4024 ftFloat,ftCurrency:Result:='FLOAT';
4025 ftDate,ftTime,ftDateTime:Result:='DATE';
4026 ftBytes,ftBlob,ftMemo,ftGraphic,ftFmtMemo,
4027 ftTypedBinary:Result:='RAW';
4028 ftVarBytes:Result:='LONG RAW';
4029 End;
4030 End;
4031 Native_msql:
4032 Begin
4033 Case DataType Of
4034 ftString:Result:='CHAR';
4035 ftSmallInt,ftInteger,ftWord:Result:='INT';
4036 ftBoolean:Result:='CHAR';
4037 ftFloat,ftCurrency:Result:='REAL';
4038 ftDate:Result:='DATE';
4039 ftTime:Result:='TIME';
4040 ftMemo,ftFmtMemo:Result:='TEXT';
4041 End;
4042 End;
4043 Native_DBase:
4044 Begin
4045 Case DataType Of
4046 ftString: Result := 'CHAR';
4047 ftDate: Result := 'DATE';
4048 ftFloat,ftCurrency: Result := 'FLOAT';
4049 ftSmallInt,ftInteger,ftWord: Result := 'INT';
4050 ftBoolean: Result := 'BOOL';
4051 ftMemo: Result := 'TEXT';
4052 ftBlob: Result := 'BLOB';
4053 Else Result := '';
4054 End;
4055 End;
4056 Native_Paradox:
4057 Begin
4058 Case DataType Of
4059 ftString: Result := 'CHAR';
4060 ftDate: Result := 'DATE';
4061 ftSmallInt: Result := 'SINT';
4062 ftInteger: Result := 'INT';
4063 ftFloat: Result := 'FLOAT';
4064 ftCurrency: Result := 'MONEY';
4065 //ftInteger: Result := 'NUMBER';
4066 ftBoolean: Result := 'BOOL';
4067 ftMemo: Result := 'TEXT';
4068 ftBlob: Result := 'BLOB';
4069 ftFmtMemo: Result := 'FMTTEXT';
4070 ftTime: Result := 'TIME';
4071 ftDateTime: Result := 'DATETIME';
4072 ftAutoInc: Result := 'AUTOINC';
4073 ftBCD: Result := 'BCD';
4074 ftBytes: Result := 'BYTES';
4075 Else Result := '';
4076 End;
4077 End;
4078 Else
4079 Begin
4080 If FDataTypes=Nil Then
4081 Begin
4082 List.Create;
4083 GetDataTypes(List);
4084 List.Destroy;
4085 End;
4086
4087 Result:='';
4088 If FDataTypes=Nil Then exit;
4089 For t:=0 To FDataTypes.Count-1 Do
4090 If TFieldType(FDataTypes.Objects[t])=DataType Then
4091 Begin
4092 Result:=FDataTypes[t];
4093 exit;
4094 End;
4095 End;
4096 End; //case
4097End;
4098
4099Function TTable.GetIndexDefs:TIndexDefs;
4100Begin
4101 If ((FIndexDefs=Nil)Or(FIndexDefs.Count=0)) Then UpdateIndexDefs;
4102 Result:=FIndexDefs;
4103End;
4104
4105Procedure UpdateIndexFieldMap(Table:TTable);
4106Var t,Index:LongInt;
4107 IndexDef:TIndexDef;
4108 s,s1:String;
4109Begin
4110 If Table.FIndexFieldMap<>Nil Then Table.FIndexFieldMap.Clear
4111 Else Table.FIndexFieldMap.Create;
4112
4113 For t:=0 To Table.IndexDefs.Count-1 Do
4114 Begin
4115 IndexDef:=Table.IndexDefs[t];
4116
4117 s:=IndexDef.Fields;
4118 While pos(';',s)<>0 Do
4119 Begin
4120 s1:=Copy(s,1,pos(';',s)-1);
4121 System.Delete(s,1,pos(';',s));
4122
4123 Index:=Table.FieldDefs.IndexOf(s1);
4124 If Index>=0 Then If Table.FIndexFieldMap.IndexOf(Pointer(Index))<0 Then
4125 Table.FIndexFieldMap.Add(Pointer(Index));
4126 End;
4127 If s<>'' Then
4128 Begin
4129 Index:=Table.FieldDefs.IndexOf(s);
4130 If Index>=0 Then If Table.FIndexFieldMap.IndexOf(Pointer(Index))<0 Then
4131 Table.FIndexFieldMap.Add(Pointer(Index));
4132 End;
4133 End;
4134End;
4135
4136Function TTable.GetIndexFieldCount:LongInt;
4137Begin
4138 If ((FIndexFieldMap=Nil)Or(FIndexFieldMap.Count=0)) Then UpdateIndexFieldMap(Self);
4139 Result:=FIndexFieldMap.Count
4140End;
4141
4142Function TTable.GetIndexField(Index:LongInt):TField;
4143Begin
4144 If ((FIndexFieldMap=Nil)Or(FIndexFieldMap.Count=0)) Then UpdateIndexFieldMap(Self);
4145 Result:=Fields[LongInt(FIndexFieldMap[Index])]
4146End;
4147
4148Procedure TTable.SetIndexField(Index:LongInt;NewValue:TField);
4149Begin
4150 GetIndexField(Index).Assign(NewValue);
4151End;
4152
4153Procedure TTable.AddIndex(Const Name:String;Fields:String;Options:TIndexOptions);
4154Var OldActive,OldOpen:Boolean;
4155 S1,s2:String;
4156 ahstmt:SQLHSTMT;
4157Begin
4158 If (Not IsTable) Then SQLError('Illegal operation');
4159
4160 OldActive:=FActive;
4161 OldOpen:=FOpened;
4162 If Not FOpened Then
4163 Begin
4164 FActive:=True;
4165 DoOpen;
4166 If Not FOpened Then Active:=False;
4167 End;
4168
4169 s1:='CREATE';
4170 If Options*[ixUnique]<>[] Then s1:=s1+' UNIQUE';
4171 s1:=s1+' INDEX '+Name+' ON '+TableName+'(';
4172 While pos(';',Fields)<>0 Do
4173 Begin
4174 s2:=Copy(Fields,1,pos(';',Fields)-1);
4175 System.Delete(Fields,1,pos(';',Fields));
4176 If s1[length(s1)]<>'(' Then s1:=s1+',';
4177 s1:=s1+s2;
4178 If FDBProcs.DBType<>Native_Msql Then
4179 Begin
4180 If Options*[ixDescending]<>[] Then s1:=s1+' DESC'
4181 Else s1:=s1+' ASC';
4182 End;
4183 End;
4184 If s1[length(s1)]<>'(' Then s1:=s1+',';
4185 s1:=s1+Fields;
4186 If FDBProcs.DBType<>Native_Msql Then
4187 Begin
4188 If Options*[ixDescending]<>[] Then s1:=s1+' DESC'
4189 Else s1:=s1+' ASC';
4190 End;
4191 s1:=s1+')';
4192
4193 If FOpened Then
4194 Begin
4195 EnterSQLProcessing;
4196 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4197
4198 If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then
4199 Begin
4200 S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4201 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4202 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4203 End;
4204
4205 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4206 LeaveSQLProcessing;
4207 End;
4208
4209 DoPost;
4210 If not OldOpen Then DoClose;
4211 FActive:=OldActive;
4212 UpdateIndexDefs;
4213End;
4214
4215Procedure TTable.DeleteIndex(Const Name: string);
4216Var OldActive,OldOpen:Boolean;
4217 S1:String;
4218 ahstmt:SQLHSTMT;
4219Begin
4220 If (Not IsTable) Then SQLError('Illegal operation');
4221
4222 OldActive:=FActive;
4223 OldOpen:=FOpened;
4224 If Not FOpened Then
4225 Begin
4226 FActive:=True;
4227 DoOpen;
4228 If Not FOpened Then Active:=False;
4229 End;
4230
4231 If FOpened Then
4232 Begin
4233 EnterSQLProcessing;
4234 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4235
4236 s1:='DROP INDEX '+Name;
4237 If FDBProcs.DBType=Native_msql Then s1:=s1+' FROM '+TableName;
4238 If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then
4239 Begin
4240 S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4241 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4242 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4243 End;
4244
4245 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4246 LeaveSQLProcessing;
4247 End;
4248
4249 DoPost;
4250 If not OldOpen Then DoClose;
4251 FActive:=OldActive;
4252 UpdateIndexDefs;
4253End;
4254
4255
4256Procedure TTable.CreateTable;
4257Var s:AnsiString;
4258 s1:String;
4259 ahstmt:SQLHSTMT;
4260 t:LongInt;
4261 FieldDef:TFieldDef;
4262 OldActive:Boolean;
4263Begin
4264 If (Not IsTable) Then SQLError('Illegal operation');
4265
4266 CheckInactive;
4267
4268 s:='CREATE TABLE '+TableName+'(';
4269
4270 For t:=0 To FieldDefs.Count-1 Do
4271 Begin
4272 FieldDef:=FieldDefs[t];
4273 s1:=FieldDef.TypeName;
4274 s:=s+FieldDef.Name+' '+s1;
4275 If ((FieldDef.DataType=ftString)Or(s1='LONG RAW')) Then
4276 s:=s+'('+tostr(FieldDef.Size)+')';
4277 If FieldDef.Required then s:=s+' NOT NULL';
4278 If FieldDef.PrimaryKey Then s:=s+' PRIMARY KEY';
4279 If FieldDef.ForeignKey<>'' Then s:=s+' REFERENCES '+FieldDef.ForeignKey;
4280 If t<>FieldDefs.Count-1 Then s:=s+',';
4281 End;
4282
4283 s:=s+')';
4284
4285 OldActive:=FActive;
4286 If Not FOpened Then
4287 Begin
4288 FActive:=True;
4289 DoOpen;
4290 If Not FOpened Then Active:=False;
4291 End;
4292
4293 If FOpened Then
4294 Begin
4295 EnterSQLProcessing;
4296 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4297
4298 If FDBProcs.SQLExecDirect(ahstmt,PChar(s)^,SQL_NTS)<>SQL_SUCCESS Then
4299 Begin
4300 S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4301 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4302 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4303 End;
4304
4305 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4306 LeaveSQLProcessing;
4307 End;
4308 DoClose;
4309 FActive:=OldActive;
4310End;
4311
4312
4313Procedure TTable.DeleteTable;
4314Var s1:String;
4315 ahstmt:SQLHSTMT;
4316Begin
4317 If (Not IsTable) Then SQLError('Illegal operation');
4318 If Active Then DoClose;
4319
4320 If Not FOpened Then
4321 Begin
4322 FActive:=True;
4323 DoOpen;
4324 If Not FOpened Then Active:=False;
4325 End;
4326
4327 If FOpened Then
4328 Begin
4329 EnterSQLProcessing;
4330 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4331
4332 If FDBProcs.SQLExecDirect(ahstmt,'DROP TABLE '+TableName,SQL_NTS)<>SQL_SUCCESS Then
4333 Begin
4334 S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4335 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4336 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4337 End;
4338
4339 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4340 LeaveSQLProcessing;
4341 End;
4342
4343 DoPost;
4344 DoClose;
4345End;
4346
4347
4348Procedure TTable.EmptyTable;
4349Var OldActive,OldOpen:Boolean;
4350 S1:String;
4351 ahstmt:SQLHSTMT;
4352Begin
4353 If (Not IsTable) Then SQLError('Illegal operation');
4354
4355 OldActive:=FActive;
4356 OldOpen:=FOpened;
4357 If Not FOpened Then
4358 Begin
4359 FActive:=True;
4360 DoOpen;
4361 If Not FOpened Then Active:=False;
4362 End;
4363
4364 If FOpened Then
4365 Begin
4366 EnterSQLProcessing;
4367 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4368
4369 If FDBProcs.SQLExecDirect(ahstmt,'DELETE * FROM '+TableName,SQL_NTS)<>SQL_SUCCESS Then
4370 Begin
4371 S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4372 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4373 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4374 End;
4375
4376 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4377 LeaveSQLProcessing;
4378 End;
4379
4380 DoPost;
4381 If not OldOpen Then DoClose;
4382 FActive:=OldActive;
4383End;
4384
4385
4386Function TTable.FindKey(Const KeyValues:Array of Const):Boolean;
4387Begin
4388 If (Not IsTable) Then SQLError('Illegal operation');
4389 Result:=False;
4390 //???
4391End;
4392
4393Procedure TTable.GetIndexNames(List: TStrings);
4394Var t:LongInt;
4395Begin
4396 List.Clear;
4397 For t:=0 To IndexDefs.Count-1 Do List.Add(IndexDefs[t].Name);
4398End;
4399
4400Procedure TTable.RenameTable(NewTableName:String);
4401Var OldActive,OldOpen:Boolean;
4402 S1:String;
4403 ahstmt:SQLHSTMT;
4404 tn:String;
4405Begin
4406 If (Not IsTable) Then SQLError('Illegal operation');
4407
4408 OldActive:=FActive;
4409 OldOpen:=FOpened;
4410 If Not FOpened Then
4411 Begin
4412 FActive:=True;
4413 DoOpen;
4414 If Not FOpened Then Active:=False;
4415 End;
4416
4417 If FOpened Then
4418 Begin
4419 EnterSQLProcessing;
4420 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4421
4422 tn:=TableName;
4423 If FDBProcs.DBType=Native_Oracle7 Then //no qualifiers !
4424 Begin
4425 If pos('.',NewTableName)<>0 Then
4426 System.Delete(NewTableName,1,pos('.',NewTableName));
4427
4428 If pos('.',tn)<>0 Then
4429 System.Delete(tn,1,pos('.',tn));
4430 End;
4431
4432 If FDBProcs.DBType=Native_Oracle7 Then s1:='RENAME '+tn+' TO '+NewTableName
4433 Else s1:='ALTER TABLE '+TableName+' RENAME '+NewTableName;
4434 If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then
4435 Begin
4436 S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4437 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4438 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4439 End;
4440
4441 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4442 LeaveSQLProcessing;
4443 End;
4444
4445 DoPost;
4446 DoClose;
4447 TableName:=NewTableName;
4448 FActive:=OldActive;
4449End;
4450
4451
4452Procedure TTable.GetNames(List:TStrings;Const Name:String);
4453Var
4454 ahstmt:SQLHSTMT;
4455 cols:SQLSMALLINT;
4456 I:LongInt;
4457 C:Array[0..4] Of cstring;
4458 OutLen:Array[0..4] Of SQLINTEGER;
4459 rc:SQLRETURN;
4460 S,S1:String;
4461 OldActive:Boolean;
4462 OldOpen:Boolean;
4463 Index:LongInt;
4464Begin
4465 List.Clear;
4466
4467 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
4468 Begin
4469 OldActive:=FActive;
4470 OldOpen:=FOpened;
4471 If Not FOpened Then
4472 Begin
4473 FActive:=True;
4474 DoOpen;
4475 If Not FOpened Then Active:=False;
4476 End;
4477
4478 If FOpened Then
4479 Begin
4480 EnterSQLProcessing;
4481 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4482
4483 If FDBProcs.SQLTables(ahstmt,Nil,0,Nil,0,Nil,0,Name,SQL_NTS)=SQL_SUCCESS Then
4484 Begin
4485 FDBProcs.SQLNumResultCols(ahstmt,cols);
4486 If cols>5 Then cols:=5;
4487 For I := 0 To cols-1 Do
4488 FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
4489 rc:=FDBProcs.SQLFetch(ahstmt);
4490 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
4491 Begin
4492 If Cols=1 Then Index:=0 //msql
4493 Else Index:=2;
4494
4495 If OutLen[Index]<>SQL_NULL_DATA Then
4496 Begin
4497 Move(C[Index],S[1],OutLen[Index]);
4498 S[0]:=Chr(OutLen[Index]);
4499 If S[length(s)]=#0 Then
4500 If length(S)>0 Then dec(S[0]);
4501 If Cols>1 Then //get qualifier
4502 If OutLen[0]<>SQL_NULL_DATA Then
4503 Begin
4504 Move(C[0],S1[1],OutLen[0]);
4505 S1[0]:=Chr(OutLen[0]);
4506 If S1[length(S1)]=#0 Then
4507 If length(S1)>0 Then dec(S1[0]);
4508 If S1<>'' Then S:=S1+'.'+S;
4509 End;
4510 List.Add(S);
4511 End;
4512 rc:=FDBProcs.SQLFetch(ahstmt);
4513 End;
4514 End;
4515
4516 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4517 LeaveSQLProcessing;
4518 End;
4519
4520 If Not OldOpen Then DoClose;
4521 FActive:=OldActive;
4522 End;
4523
4524End;
4525
4526Procedure TTable.GetViewNames(List:TStrings);
4527Begin
4528 GetNames(List,'VIEW');
4529End;
4530
4531Procedure TTable.GetSystemTableNames(List:TStrings);
4532Begin
4533 GetNames(List,'SYSTEM TABLE');
4534End;
4535
4536Procedure TTable.GetSynonymNames(List:TStrings);
4537Begin
4538 GetNames(List,'SYNONYM');
4539End;
4540
4541Function MapSQLType(colType:SQLSMALLINT):TFieldType;
4542Begin
4543 Case colType Of
4544 SQL_CHAR:Result:=ftString;
4545 SQL_NUMERIC:Result:=ftFloat;
4546 SQL_DECIMAL:Result:=ftFloat;
4547 SQL_INTEGER:Result:=ftInteger;
4548 SQL_SMALLINT:Result:=ftSmallInt;
4549 SQL_FLOAT:Result:=ftFloat;
4550 SQL_REAL:Result:=ftFloat;
4551 SQL_DOUBLE:Result:=ftFloat;
4552 SQL_DATE:Result:=ftDate;
4553 SQL_TIME:Result:=ftTime;
4554 SQL_TIMESTAMP:Result:=ftDateTime;
4555 SQL_VARCHAR:Result:=ftString;
4556 SQL_LONGVARCHAR:Result:=ftMemo;
4557 SQL_BINARY:Result:=ftBlob;
4558 SQL_VARBINARY:Result:=ftBlob;
4559 SQL_LONGVARBINARY:Result:=ftBlob;
4560 {SQL_BIGINT =-5; /* Not supported */
4561 SQL_TINYINT =-6; /* Not supported */}
4562 SQL_BIT:Result:=ftBoolean;
4563 SQL_GRAPHIC:Result:=ftGraphic;
4564 SQL_VARGRAPHIC:Result:=ftGraphic;
4565 SQL_LONGVARGRAPHIC:Result:=ftGraphic;
4566 SQL_BLOB:Result:=ftBlob;
4567 SQL_CLOB:Result:=ftBlob;
4568 SQL_DBCLOB:Result:=ftBlob;
4569 Else Result:=ftUnknown;
4570 End; {Case}
4571End;
4572
4573
4574Procedure TTable.GetDataTypes(List:TStrings);
4575Var
4576 OldActive:Boolean;
4577 OldOpen:Boolean;
4578 Index:LongInt;
4579
4580 Procedure GetType(Typ:SQLSMALLINT);
4581 Var cols:SQLSMALLINT;
4582 I:LongInt;
4583 C:cstring;
4584 OutLen:SQLINTEGER;
4585 rc:SQLRETURN;
4586 S,S1:String;
4587 ahstmt:SQLHSTMT;
4588 Begin
4589 EnterSQLProcessing;
4590 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4591
4592 If FDBProcs.SQLGetTypeInfo(ahstmt,Typ)=SQL_SUCCESS Then
4593 Begin
4594 FDBProcs.SQLNumResultCols(ahstmt,cols);
4595 If cols=0 Then exit;
4596 FDBProcs.SQLBindCol(ahstmt, 1, SQL_C_CHAR, C, 255, OutLen);
4597 rc:=FDBProcs.SQLFetch(ahstmt);
4598 If ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Then
4599 Begin
4600 If OutLen<>SQL_NULL_DATA Then
4601 Begin
4602 Move(C,S[1],OutLen);
4603 S[0]:=Chr(OutLen);
4604 If S[length(s)]=#0 Then
4605 If length(s)>0 Then dec(S[0]);
4606 UpcaseStr(S);
4607 If List.IndexOf(S)<0 Then List.AddObject(S,Pointer(MapSQLType(Typ)));
4608 End;
4609 End;
4610 End;
4611
4612 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4613 LeaveSQLProcessing;
4614 End;
4615
4616 Procedure ListAddObject(Const s:String;DataType:TFieldType);
4617 Begin
4618 List.AddObject(s,Pointer(DataType));
4619 End;
4620
4621Begin
4622 List.Clear;
4623 Case FDBProcs.DBType Of
4624 Native_Oracle7:
4625 Begin
4626 ListAddObject('CHAR',ftString);
4627 ListAddObject('VARCHAR2',ftString);
4628 ListAddObject('FLOAT',ftFloat);
4629 ListAddObject('INT',ftInteger);
4630 ListAddObject('DATE',ftDateTime);
4631 ListAddObject('RAW',ftBlob);
4632 ListAddObject('LONG RAW',ftBlob);
4633 End;
4634 Native_msql:
4635 Begin
4636 ListAddObject('CHAR',ftString);
4637 ListAddObject('INT',ftInteger);
4638 ListAddObject('UINT',ftInteger);
4639 ListAddObject('REAL',ftFloat);
4640 ListAddObject('TEXT',ftMemo);
4641 ListAddObject('DATE',ftDate);
4642 ListAddObject('TIME',ftTime);
4643 ListAddObject('MONEY',ftInteger);
4644 End;
4645 Native_DBase:
4646 Begin
4647 ListAddObject('CHAR',ftString);
4648 ListAddObject('INT',ftInteger);
4649 ListAddObject('FLOAT',ftFloat);
4650 ListAddObject('TEXT',ftMemo);
4651 ListAddObject('DATE',ftDate);
4652 ListAddObject('BOOL',ftBoolean);
4653 ListAddObject('BLOB',ftBlob);
4654 End;
4655 Native_Paradox:
4656 Begin
4657 ListAddObject('CHAR',ftString);
4658 ListAddObject('DATE',ftDate);
4659 ListAddObject('SINT',ftSmallInt);
4660 ListAddObject('INT',ftInteger);
4661 ListAddObject('FLOAT',ftFloat);
4662 ListAddObject('MONEY',ftCurrency);
4663 ListAddObject('NUMBER',ftInteger);
4664 ListAddObject('BOOL',ftBoolean);
4665 ListAddObject('TEXT',ftMemo);
4666 ListAddObject('BLOB',ftBlob);
4667 ListAddObject('FMTTEXT',ftFmtMemo);
4668 ListAddObject('TIME',ftTime);
4669 ListAddObject('DATETIME',ftDateTime);
4670 ListAddObject('AUTOINC',ftAutoInc);
4671 ListAddObject('BCD',ftBCD);
4672 ListAddObject('BYTES',ftBytes);
4673 End;
4674 Else
4675 Begin
4676 If FDataTypes<>Nil Then
4677 Begin
4678 List.Assign(FDataTypes);
4679 exit;
4680 End;
4681
4682 If @FDBProcs.SQLGetTypeInfo=Nil Then exit;
4683 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
4684 Begin
4685 OldActive:=FActive;
4686 OldOpen:=FOpened;
4687 If Not FOpened Then
4688 Begin
4689 FActive:=True;
4690 DoOpen;
4691 If Not FOpened Then Active:=False;
4692 End;
4693
4694 If FOpened Then
4695 Begin
4696 GetType(SQL_BIGINT);
4697 GetType(SQL_BINARY);
4698 GetType(SQL_BIT);
4699 GetType(SQL_CHAR);
4700 GetType(SQL_DATE);
4701 GetType(SQL_DECIMAL);
4702 GetType(SQL_DOUBLE);
4703 GetType(SQL_FLOAT);
4704 GetType(SQL_INTEGER);
4705 GetType(SQL_LONGVARBINARY);
4706 GetType(SQL_LONGVARCHAR);
4707 GetType(SQL_NUMERIC);
4708 GetType(SQL_REAL);
4709 GetType(SQL_SMALLINT);
4710 GetType(SQL_TIME);
4711 GetType(SQL_TIMESTAMP);
4712 GetType(SQL_TINYINT);
4713 GetType(SQL_VARBINARY);
4714 GetType(SQL_VARCHAR);
4715 End;
4716
4717 If Not OldOpen Then DoClose;
4718 FActive:=OldActive;
4719
4720 If FDataTypes=Nil Then If List.Count>0 Then
4721 Begin
4722 FDataTypes.Create;
4723 FDataTypes.Assign(List);
4724 End;
4725 End;
4726 End;
4727 End;
4728End;
4729
4730
4731Procedure TTable.GetForeignKeys(List:TStrings);
4732Begin
4733 GetKeys(List,False);
4734End;
4735
4736
4737Procedure TTable.GetTableNames(List:TStrings);
4738Begin
4739 GetNames(List,'TABLE');
4740End;
4741
4742
4743Procedure TTable.SetTableLock(LockType:TLockType;Lock:Boolean);
4744Var C:cstring;
4745 ahstmt:SQLHSTMT;
4746 S:String;
4747Begin
4748 If Lock Then
4749 Begin
4750 C:='LOCK TABLE '+TableName+' IN ';
4751 If LockType=ltReadLock Then C:=C+'EXCLUSIVE'
4752 Else C:=C+'SHARE';
4753 C:=C+' MODE';
4754 End
4755 Else C:='ROLLBACK';
4756
4757 EnterSQLProcessing;
4758 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4759
4760 If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then
4761 Begin
4762 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4763 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4764 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
4765 End;
4766
4767 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4768 LeaveSQLProcessing;
4769End;
4770
4771Procedure TTable.LockTable(LockType:TLockType);
4772Begin
4773 SetTableLock(LockType,True);
4774End;
4775
4776Procedure TTable.UnlockTable(LockType:TLockType);
4777Begin
4778 SetTableLock(LockType,False);
4779End;
4780
4781
4782Procedure TTable.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
4783Var S:String;
4784Begin
4785 If ResName = rnDBTable Then
4786 Begin
4787 Move(Data,S,DataLen);
4788 TableName:=S;
4789 End
4790 Else Inherited ReadSCUResource(ResName,Data,DataLen);
4791End;
4792
4793
4794Function TTable.WriteSCUResource(Stream:TResourceStream):Boolean;
4795Var S:String;
4796Begin
4797 Result := False;
4798 If Inherited WriteSCUResource(Stream) Then
4799 Begin
4800 S:=TableName;
4801 Result:=Stream.NewResourceEntry(rnDBTable,S,Length(S)+1);
4802 End;
4803End;
4804
4805
4806Function TTable.GetTableName:String;
4807Begin
4808 Result:=FTableName^;
4809End;
4810
4811
4812Procedure TTable.SetupComponent;
4813Begin
4814 AssignStr(FTableName,'');
4815 AssignStr(FMasterFields,'');
4816
4817 Inherited SetupComponent;
4818
4819 Name:='Table';
4820End;
4821
4822
4823Procedure TTable.SetActive(NewValue:Boolean);
4824Begin
4825 If FActive = NewValue Then exit;
4826
4827 Inherited SetActive(NewValue);
4828
4829 If FActive Then
4830 Begin
4831 RefreshTable;
4832 FActive := FOpened;
4833 End
4834 Else DoClose;
4835End;
4836
4837
4838Procedure TTable.RefreshTable;
4839Begin
4840 If ((csReading In ComponentState) Or (FDataSetLocked)) Then
4841 Begin
4842 FRefreshOnLoad := FActive;
4843 Exit;
4844 End;
4845 DoOpen;
4846 If Not FOpened Then Exit;
4847 If TableName <> '' Then QueryTable;
4848End;
4849
4850
4851Procedure TTable.SetTableName(NewValue:String);
4852Begin
4853 If GetTableName=NewValue Then Exit;
4854
4855 If FIndexDefs<>Nil Then FIndexDefs.Clear;
4856 AssignStr(FTableName,NewValue);
4857
4858 FSelect.Clear;
4859 NewValue:='SELECT * FROM '+ NewValue;
4860 FSelect.Add(NewValue);
4861
4862 If FActive Then
4863 Begin
4864 RefreshTable;
4865
4866 DataChange(deTableNameChanged);
4867 End;
4868End;
4869
4870Function TTable.GetPassword:String;
4871Begin
4872 Result:=FDBProcs.pwd;
4873End;
4874
4875Function TTable.GetUserId:String;
4876Begin
4877 Result:=FDBProcs.uid;
4878End;
4879
4880Procedure TTable.SetPassword(NewValue:String);
4881Begin
4882 If FOpened Then
4883 Begin
4884 ErrorBox(LoadNLSStr(SCannotPerformDBAction));
4885 Exit;
4886 End;
4887 FDBProcs.pwd:=NewValue;
4888End;
4889
4890Procedure TTable.SetUserId(NewValue:String);
4891Begin
4892 If FOpened Then
4893 Begin
4894 ErrorBox(LoadNLSStr(SCannotPerformDBAction));
4895 Exit;
4896 End;
4897 FDBProcs.uid:=NewValue;
4898End;
4899
4900Destructor TTable.Destroy;
4901Begin
4902 DoClose;
4903 FreeDBProcs(FDBProcs);
4904 AssignStr(FTableName,'');
4905 If FServants<>Nil Then
4906 Begin
4907 NotifyServants(Self);
4908 FServants.Destroy;
4909 End;
4910 FServants:=Nil;
4911 If FDataTypes<>Nil Then
4912 Begin
4913 FDataTypes.Destroy;
4914 FDataTypes:=Nil;
4915 End;
4916 If FIndexDefs<>Nil Then
4917 Begin
4918 FIndexDefs.Destroy;
4919 FIndexDefs:=Nil;
4920 End;
4921 If FIndexFieldMap<>Nil Then
4922 Begin
4923 FIndexFieldMap.Destroy;
4924 FIndexFieldMap:=Nil;
4925 End;
4926 If FMasterSource<>Nil Then
4927 If FMasterSource.DataSet Is TTable Then
4928 TTable(FMasterSource.DataSet).ConnectServant(Self,False);
4929 AssignStr(FMasterFields,'');
4930
4931 Inherited Destroy;
4932End;
4933
4934Procedure TTable.Loaded;
4935Begin
4936 If FTempMasterSource<>Nil Then
4937 If FTempMasterSource.DataSet Is TTable Then
4938 If FMasterSource=Nil Then MasterSource:=FTempMasterSource;
4939 Inherited Loaded;
4940End;
4941
4942{$HINTS OFF}
4943Procedure TTable.UpdateLinkList(Const PropertyName:String;LinkList:TList);
4944Var T:LongInt;
4945 DataSource:TDataSource;
4946Begin
4947 For T:=LinkList.Count-1 DownTo 0 Do
4948 Begin
4949 DataSource:=TDataSource(LinkList[T]);
4950 If DataSource Is TDataSource Then
4951 Begin
4952 If DataSource.DataSet Is TTable Then
4953 Begin
4954 //no recursive elements !!
4955 If TTable(DataSource.DataSet)=Self Then LinkList.Remove(DataSource);
4956 End
4957 Else
4958 Begin
4959 //no DataSources that are Not linked To tables !
4960 LinkList.Remove(DataSource);
4961 End;
4962 End;
4963 End;
4964End;
4965{$HINTS ON}
4966
4967Procedure TTable.SetMasterSource(NewValue:TDataSource);
4968Var OldLocked:Boolean;
4969 IsLoaded:Boolean;
4970Begin
4971 If NewValue=FMasterSource Then Exit;
4972 If NewValue<>Nil Then
4973 Begin
4974 If Not (NewValue.DataSet Is TTable) Then
4975 Begin
4976 IsLoaded:=((ComponentState*[csReading]=[])And(Not FDataSetLocked));
4977 If ((NewValue.DataSet=Nil)And(Not IsLoaded)) Then FTempMasterSource:=NewValue
4978 Else If ComponentState*[csDesigning]<>[] Then ErrorBox(LoadNLSStr(SDataSourceLinkError));
4979 Exit;
4980 End;
4981 If TTable(NewValue.DataSet)=Self Then
4982 Begin
4983 If ComponentState*[csDesigning]<>[] Then ErrorBox('Illegal recursive DataSource link');
4984 Exit;
4985 End;
4986 If ((FServants<>Nil)And(FServants.IndexOf(NewValue.DataSet)>=0)) Then
4987 Begin
4988 If ComponentState*[csDesigning]<>[] Then ErrorBox('Illegal circular DataSource link');
4989 Exit;
4990 End;
4991
4992 End;
4993
4994 //prevent call Of RefreshTable In ConnectServant
4995 OldLocked:=FDataSetLocked;
4996 FDataSetLocked:=True;
4997 If FMasterSource<>Nil Then
4998 If FMasterSource.DataSet Is TTable Then
4999 TTable(FMasterSource.DataSet).ConnectServant(Self,False);
5000 FMasterSource:=NewValue;
5001 FDataSetLocked:=OldLocked;
5002 If FMasterSource<>Nil Then
5003 Begin
5004 If FMasterSource.DataSet Is TTable Then
5005 TTable(FMasterSource.DataSet).ConnectServant(Self,True)
5006 Else If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable;
5007 End
5008 Else If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable;
5009End;
5010
5011Function TTable.GetMasterFields:String;
5012Begin
5013 Result:=FMasterFields^;
5014End;
5015
5016Procedure TTable.SetMasterFields(Const NewValue:String);
5017Begin
5018 If GetMasterFields=NewValue Then exit;
5019
5020 AssignStr(FMasterFields,NewValue);
5021 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable;
5022End;
5023
5024Procedure TTable.ConnectServant(Servant:TTable;Connect:Boolean);
5025Begin
5026 If Connect Then
5027 Begin
5028 If FServants=Nil Then FServants.Create;
5029 FServants.Add(Servant);
5030 End
5031 Else If FServants<>Nil Then
5032 Begin
5033 If FServants.IndexOf(Servant)>=0 Then FServants.Remove(Servant);
5034 End;
5035
5036 If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then
5037 Servant.RefreshTable;
5038End;
5039
5040Procedure TTable.DataChange(event:TDataChange);
5041Var T:LongInt;
5042 Servant:TTable;
5043Begin
5044 If FServants<>Nil Then For T:=0 To FServants.Count-1 Do
5045 Begin
5046 Servant:=FServants[T];
5047 If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then
5048 Servant.RefreshTable;
5049 End;
5050
5051 Inherited DataChange(event);
5052End;
5053
5054
5055Function TTable.GetResultColRow(Col,Row:LongInt):TField;
5056Var FieldDef:TFieldDef;
5057 I,t:LongInt;
5058 field:TField;
5059 rc:SQLRETURN;
5060 OutLen:LongInt;
5061 Temp:Pointer;
5062 NewLen:LongInt;
5063 MapType:LongInt;
5064 S:String;
5065 ActRows:LongWord;
5066 RowStatus:Word;
5067 ExtFetchOk:Boolean;
5068 e:Extended;
5069 Header:TGraphicHeader;
5070Label again,err;
5071Begin
5072 Result := Nil;
5073 If Not FOpened Then Exit;
5074
5075 Result := Inherited GetResultColRow(Col,Row);
5076 If Result <> Nil Then exit;
5077
5078 If FDBProcs.ahstmt=0 Then Exit; {no previous Select Command Or no more Rows}
5079
5080 /* Store Result Row(S) */
5081again:
5082 //Try if we are able to retrieve cursored rows !
5083 If Self Is TStoredProc Then //due to "Function sequence error"
5084 Begin
5085 rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
5086 ExtFetchOk:=False;
5087 End
5088 Else
5089 Begin
5090 rc:=FDBProcs.SQLExtendedFetch(FDBProcs.ahstmt,SQL_FETCH_ABSOLUTE,
5091 Row+1,ActRows,RowStatus);
5092 ExtFetchOk:=rc<>SQL_ERROR;
5093 If not ExtFetchOk Then rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); //Driver not capable (DB2 !)
5094 End;
5095
5096 FieldDef:=FFieldDefs[0];
5097
5098 If ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Then
5099 Begin
5100 For I:=0 To FFieldDefs.Count-1 Do
5101 Begin
5102 FieldDef:=FFieldDefs[I];
5103 {Create Row}
5104 Field := FieldDef.CreateField(Nil);
5105 If ExtFetchOk Then Field.FRow:=Row+1
5106 Else Field.FRow:=FieldDef.Fields.Count;
5107 Field.FCol:=I;
5108
5109 Case FieldDef.DataType Of
5110 ftBytes,ftVarBytes,ftBlob,ftMemo,ftGraphic,
5111 ftFmtMemo,ftTypedBinary:MapType:=SQL_C_BINARY;
5112 ftFloat:
5113 Begin
5114 Case FieldDef.Size Of
5115 4:MapType:=SQL_C_FLOAT;
5116 Else MapType:=SQL_C_DOUBLE;
5117 End; //case
5118 End;
5119 Else MapType:=SQL_C_DEFAULT;
5120 End;
5121
5122 rc:=FDBProcs.SQLGetData(FDBProcs.ahstmt,I+1,MapType,field.FValue^,
5123 FieldDef.Size,OutLen);
5124 If rc<>SQL_ERROR Then
5125 Begin
5126 If ((rc=SQL_SUCCESS_WITH_INFO)And(OutLen>field.FValueLen)And
5127 (MapType=SQL_C_BINARY)) Then
5128 Begin
5129 NewLen:=OutLen-field.FValueLen;
5130 GetMem(Temp,OutLen);
5131 Move(Field.FValue^,Temp^,Field.FValueLen);
5132 FreeMem(Field.FValue,Field.FValueLen);
5133 Field.FValue:=Temp;
5134 Inc(Temp,field.FValueLen);
5135 Field.FValueLen:=OutLen;
5136 rc:=FDBProcs.SQLGetData(FDBProcs.ahstmt,I+1,MapType,Temp^,
5137 NewLen,OutLen);
5138 If rc=SQL_ERROR Then
5139 Begin
5140 Field.Destroy;
5141 Goto err;
5142 End;
5143 OutLen:=Field.FValueLen+1;
5144 End;
5145
5146 If OutLen=SQL_NULL_DATA Then
5147 Begin
5148 Field.FreeMemory; //TOM TEST
5149 End
5150 Else
5151 Begin
5152 If OutLen<=field.FValueLen Then
5153 Begin
5154 GetMem(Temp,OutLen);
5155 Move(Field.FValue^,Temp^,OutLen);
5156 FreeMem(Field.FValue,Field.FValueLen);
5157 Field.FValue:=Temp;
5158 Field.FValueLen:=OutLen;
5159 End;
5160 End;
5161
5162 If ExtFetchOk Then
5163 Begin
5164 If Row<=FieldDef.Fields.Count-1 Then
5165 Begin
5166 FieldDef.Fields[Row]:=Field;
5167 End
5168 Else
5169 Begin
5170 For t:=FieldDef.Fields.Count+1 To Row Do
5171 FieldDef.Fields.Add(Nil);
5172 FieldDef.Fields.Add(Field);
5173 End;
5174 End
5175 Else FieldDef.Fields.Add(Field);
5176 End
5177 Else
5178 Begin
5179 Field.Destroy;
5180 Goto err;
5181 End;
5182
5183 If Field Is TBlobField Then // check graphic header
5184 Begin
5185 If Field.FValueLen >= SizeOf(TGraphicHeader) Then
5186 Begin
5187 move(Field.FValue^, Header, SizeOf(TGraphicHeader));
5188 If (Header.Count = 1) And (Header.HType = $0100) And
5189 (Header.Size = Field.FValueLen - SizeOf(TGraphicHeader)) Then
5190 Begin
5191 GetMem(Temp, Header.Size);
5192 inc(Field.FValue, SizeOf(TGraphicHeader));
5193 Move(Field.FValue^,Temp^, Header.Size);
5194 dec(Field.FValue, SizeOf(TGraphicHeader));
5195 FreeMem(Field.FValue, Field.FValueLen);
5196 Field.FValue := Temp;
5197 Field.FValueLen := Header.Size;
5198 //Field.FBlobType := ftGraphic;
5199 End;
5200 End;
5201 End;
5202 End;
5203
5204 FieldDef:=FFieldDefs[Col];
5205
5206 If ((ExtFetchOk)Or(Row=FieldDef.Fields.Count-1)) Then
5207 Begin
5208 {result found}
5209 Result:=FieldDef.Fields.Items[Row];
5210 exit;
5211 End;
5212
5213 Goto again; {fetch Next Row}
5214 End
5215 Else
5216 Begin
5217 {no more Rows}
5218 If rc=SQL_ERROR Then
5219 Begin
5220err:
5221 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
5222 CloseStmt;
5223 SQLError('Error fetching result row '+FieldDef.Name+#13#10+S);
5224 End;
5225
5226 CloseStmt;
5227 End;
5228End;
5229
5230
5231Procedure TTable.GetKeys(List:TStrings;Primary:Boolean);
5232Var ahstmt:SQLHSTMT;
5233 cols:SQLSMALLINT;
5234 C:Array[0..8] Of cstring;
5235 cc:cstring;
5236 S,S1:String;
5237 I:LongInt;
5238 OutLen:Array[0..8] Of SQLINTEGER;
5239 rc:SQLRETURN;
5240 Offset,Offset1:LongInt;
5241Begin
5242 If Primary Then
5243 Begin
5244 Offset:=0;
5245 Offset1:=0;
5246 End
5247 Else
5248 Begin
5249 Offset:=4;
5250 Offset1:=-4;
5251 End;
5252
5253 EnterSQLProcessing;
5254 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5255
5256 cc:=TableName;
5257 Try //Some DB2 Servers return a GPF here ...
5258 rc:=SQL_ERROR;
5259 If TableName<>'' Then
5260 Begin
5261 If Primary Then
5262 rc:=FDBProcs.SQLPrimaryKeys(ahstmt,Nil,0,Nil,0,cc,SQL_NTS)
5263 Else If @FDBProcs.SQLForeignKeys<>Nil Then
5264 rc:=FDBProcs.SQLForeignKeys(ahstmt,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0,cc,SQL_NTS);
5265 End
5266 Else
5267 Begin
5268 If Primary Then
5269 rc:=FDBProcs.SQLPrimaryKeys(ahstmt,Nil,0,Nil,0,Nil,0)
5270 Else If @FDBProcs.SQLForeignKeys<>Nil Then
5271 rc:=FDBProcs.SQLForeignKeys(ahstmt,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0);
5272 End;
5273
5274 If rc=SQL_SUCCESS Then
5275 Begin
5276 FDBProcs.SQLNumResultCols(ahstmt,cols);
5277 If cols>8 Then cols:=8;
5278 For I := 0 To cols-1 Do
5279 FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
5280 rc:=FDBProcs.SQLFetch(ahstmt);
5281 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
5282 Begin
5283 If OutLen[3+Offset]<>SQL_NULL_DATA Then
5284 Begin
5285 Move(C[3+Offset],S[1],OutLen[3+Offset]);
5286 S[0]:=Chr(OutLen[3+Offset]);
5287 If S[Length(S)]=#0 Then
5288 If length(S)>0 Then dec(S[0]);
5289 If ((TableName='')Or(Not Primary)) Then
5290 Begin
5291 If OutLen[2+Offset+Offset1]<>SQL_NULL_DATA Then
5292 Begin
5293 Move(C[2+Offset+Offset1],S1[1],OutLen[2+Offset+Offset1]);
5294 S1[0]:=Chr(OutLen[2+Offset+Offset1]);
5295 If S1[Length(S1)]=#0 Then
5296 If length(S1)>0 Then dec(S1[0]);
5297 If not Primary Then
5298 Begin
5299 S:=S+'>'+S1;
5300 If OutLen[2+Offset+Offset1+1]<>SQL_NULL_DATA Then
5301 Begin
5302 Move(C[2+Offset+Offset1+1],S1[1],OutLen[2+Offset+Offset1+1]);
5303 S1[0]:=Chr(OutLen[2+Offset+Offset1+1]);
5304 If S1[Length(S1)]=#0 Then
5305 If length(S1)>0 Then dec(S1[0]);
5306 S:=S+'.'+S1;
5307 End;
5308 End
5309 Else S:=S1+'.'+S;
5310 End;
5311 End;
5312 List.Add(S);
5313 End;
5314 rc:=FDBProcs.SQLFetch(ahstmt);
5315 End;
5316 End;
5317 Except
5318 List.Clear;
5319 End;
5320
5321 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5322 LeaveSQLProcessing;
5323End;
5324
5325
5326Procedure TTable.DoOpen;
5327Var rc:SQLRETURN;
5328 s:String;
5329 fmode:Longword;
5330Begin
5331 If Not FActive Then Exit;
5332
5333 If Not FillDBProcs(FDBProcs) Then
5334 Begin
5335 LeaveSQLProcessing;
5336 ErrorBox(LoadNLSStr(SErrLoadingDB));
5337 Active:=False;
5338 Exit; {Error}
5339 End;
5340
5341 If Not FOpened Then
5342 Begin
5343 EnterSQLProcessing;
5344
5345 Try
5346 If FBeforeOpen<>Nil Then FBeforeOpen(Self);
5347
5348 FDBProcs.ahstmt:=0;
5349 FDBProcs.ahenv:=0;
5350 If AllocateDBEnvironment(FDBProcs)<>SQL_SUCCESS Then
5351 Begin
5352 LeaveSQLProcessing;
5353 ErrorBox(LoadNLSStr(SErrAllocDBEnv)+'.'+
5354 SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
5355 Active:=False;
5356 Exit;
5357 End;
5358
5359 {Connect To Server}
5360 FDBProcs.ahdbc:=0;
5361 If FDBProcs.SQLAllocConnect(FDBProcs.ahenv,FDBProcs.ahdbc)<>SQL_SUCCESS Then
5362 Begin
5363 LeaveSQLProcessing;
5364 ErrorBox(LoadNLSStr(SErrAllocDBConnect)+'.'+
5365 SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
5366 DoClose;
5367 Exit;
5368 End;
5369
5370 {Set autocommit OFF}
5371 If FDBProcs.SQLSetConnectOption(FDBProcs.ahdbc,SQL_AUTOCOMMIT,SQL_AUTOCOMMIT_OFF)<>SQL_SUCCESS Then
5372 Begin
5373 LeaveSQLProcessing;
5374 ErrorBox(LoadNLSStr(SErrSettingDBOpts)+'.'+
5375 SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
5376 DoClose;
5377 Exit;
5378 End;
5379
5380 {Connect}
5381 Try
5382 If FDBProcs.uid='' Then
5383 Begin
5384 If FDBProcs.pwd='' Then
5385 rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5386 Nil,0,Nil,0)
5387 Else
5388 rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5389 Nil,0,FDBProcs.pwd,SQL_NTS);
5390 End
5391 Else If FDBProcs.pwd='' Then
5392 Begin
5393 rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5394 FDBProcs.uid,SQL_NTS,Nil,0);
5395 End
5396 Else rc:= FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5397 FDBProcs.uid,SQL_NTS,FDBProcs.pwd,SQL_NTS);
5398 If rc<>SQL_SUCCESS Then
5399 Begin
5400 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0);
5401 DoClose;
5402 SQLError(LoadNLSStr(SErrorDBConnecting)+' "'+DataBase+'".'+#13#10+S);
5403 End;
5404 Except
5405 ON E:ESQLError Do
5406 Begin
5407 LeaveSQLProcessing;
5408 ErrorBox(E.Message);
5409 Exit;
5410 End;
5411 Else Raise;
5412 End;
5413
5414 FOpened:=True;
5415
5416 LeaveSQLProcessing;
5417 If FAfterOpen<>Nil Then AfterOpen(Self);
5418 Except
5419 LeaveSQLProcessing;
5420 Raise;
5421 End;
5422 End;
5423End;
5424
5425
5426Procedure TTable.DoClose;
5427Begin
5428 Try
5429 If FBeforeClose<>Nil Then FBeforeClose(Self);
5430
5431 If FOpened Then
5432 Begin
5433 CloseStmt;
5434 Post; //Commit All transactions
5435 End;
5436
5437 FActive:=False;
5438 FDataSetLocked:=True;
5439 FFieldDefs.Clear;
5440 FDataSetLocked:=False;
5441
5442 If FDBProcs.ahdbc <> 0 Then
5443 Begin
5444 If FOpened Then
5445 If FDBProcs.SQLDisconnect(FDBProcs.ahdbc) <> SQL_SUCCESS Then
5446 ErrorBox('Disconnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
5447 If FDBProcs.SQLFreeConnect(FDBProcs.ahdbc) <> SQL_SUCCESS Then
5448 ErrorBox('FreeConnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
5449 FDBProcs.ahdbc := 0;
5450 End;
5451
5452 If FDBProcs.ahenv <> 0 Then
5453 Begin
5454 If FDBProcs.SQLFreeEnv(FDBProcs.ahenv) <> SQL_SUCCESS Then
5455 ErrorBox('FreeEnv error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
5456 FDBProcs.ahenv := 0;
5457 End;
5458
5459 Inherited DoClose;
5460
5461 DataChange(deDataBaseChanged);
5462
5463 If FAfterClose<>Nil Then FAfterClose(Self);
5464 Except
5465 Raise;
5466 End;
5467End;
5468
5469
5470Procedure TTable.GetStoredProcNames(List:TStrings);
5471Var
5472 ahstmt:SQLHSTMT;
5473 cols:SQLSMALLINT;
5474 I:LongInt;
5475 C:Array[0..4] Of cstring;
5476 OutLen:Array[0..4] Of SQLINTEGER;
5477 rc:SQLRETURN;
5478 S,S1:String;
5479 OldActive:Boolean;
5480 OldOpen:Boolean;
5481Begin
5482 Inherited GetStoredProcNames(List);
5483
5484 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
5485 Begin
5486 OldActive:=FActive;
5487 OldOpen:=FOpened;
5488 If Designed Then
5489 If Not FOpened Then
5490 Begin
5491 FActive:=True;
5492 DoOpen;
5493 If Not FOpened Then Active:=False;
5494 End;
5495
5496 If FOpened Then
5497 Begin
5498 EnterSQLProcessing;
5499 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5500
5501 If FDBProcs.SQLProcedures(ahstmt,Nil,0,Nil,0,Nil,0)=SQL_SUCCESS Then
5502 Begin
5503 FDBProcs.SQLNumResultCols(ahstmt,cols);
5504 If cols>3 Then cols:=3;
5505 For I := 0 To cols-1 Do
5506 FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
5507 rc:=FDBProcs.SQLFetch(ahstmt);
5508 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
5509 Begin
5510 If OutLen[2]<>SQL_NULL_DATA Then
5511 Begin
5512 Move(C[2],S[1],OutLen[2]);
5513 S[0]:=Chr(OutLen[2]);
5514 If S[length(S)]=#0 Then
5515 If length(S)>0 Then dec(S[0]);
5516 If OutLen[0]<>SQL_NULL_DATA Then
5517 Begin
5518 Move(C[0],S1[1],OutLen[0]);
5519 S1[0]:=Chr(OutLen[0]);
5520 If S1[length(S1)]=#0 Then
5521 If length(S1)>0 Then dec(S1[0]);
5522 If S1<>'' Then S:=S1+'.'+S;
5523 End;
5524 List.Add(S);
5525 End;
5526 rc:=FDBProcs.SQLFetch(ahstmt);
5527 End;
5528 End
5529 Else List.Clear;
5530
5531 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5532 LeaveSQLProcessing;
5533 End;
5534
5535 If Designed Then
5536 Begin
5537 If Not OldOpen Then DoClose;
5538 FActive:=OldActive;
5539 End;
5540 End;
5541End;
5542
5543
5544Procedure TTable.GetDataSources(List:TStrings);
5545Var
5546 AliasName,DriverName,Advanced,UID:String;
5547 t,Count:LongInt;
5548Begin
5549 List.Clear;
5550
5551 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
5552 Begin
5553 Count:=GetDbAliasNamesCount;
5554 For t:=0 To Count-1 Do
5555 Begin
5556 GetDBAlias(t,AliasName,DriverName,Advanced,UID);
5557 List.Add(AliasName);
5558 End;
5559 End;
5560End;
5561
5562
5563Procedure TTable.DoDelete;
5564Var C,c1:cstring;
5565 ahstmt,ahstmt1:SQLHSTMT;
5566 S:String;
5567 resultCols:SQLSMALLINT;
5568 rc:SQLRETURN;
5569 T:LongInt;
5570 T1,RowId:LongInt;
5571 Res:SQLINTEGER;
5572 OracleRowId:CString;
5573Begin
5574 If ReadOnly Then SQLError('Cannot modify a readonly dataset!');
5575
5576 If (Not IsTable) Then exit; //cannot update this result set...
5577
5578 EnterSQLProcessing;
5579 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5580
5581 Case FDBProcs.DBType Of
5582 Native_mSQL: C:='SELECT _rowid,'+Fields[0].FieldName+' FROM '+TableName;
5583 Native_Oracle7: C:='SELECT ROWID,'+Fields[0].FieldName+' FROM '+TableName+' FOR UPDATE'
5584 Else C:='SELECT * FROM '+TableName+' FOR UPDATE';
5585 End;
5586
5587 If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then
5588 Begin
5589 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5590 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5591 SQLError('Error executing SELECT SQL statement: '+S);
5592 End;
5593
5594 FDBProcs.SQLNumResultCols(ahstmt,resultCols);
5595 If resultCols=0 Then //Not A Select statement
5596 Begin
5597 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5598 LeaveSQLProcessing;
5599 Exit;
5600 End;
5601
5602 If FDBProcs.DBType=Native_mSQL Then T1:=Fields[0].FRow-1
5603 Else T1:=Fields[0].FRow;
5604
5605 For T:=0 To T1 Do
5606 Begin
5607 rc:=FDBProcs.SQLFetch(ahstmt);
5608 If ((rc=SQL_NO_DATA_FOUND)Or(rc=SQL_ERROR)) Then
5609 Begin
5610 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5611 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5612 SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5613 End;
5614 End;
5615
5616 If FDBProcs.DBType=Native_mSQL Then
5617 Begin
5618 If FDBProcs.SQLGetData(ahstmt,1,SQL_INTEGER,RowId,4,Res)<>SQL_SUCCESS Then
5619 Begin
5620 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5621 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5622 SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5623 End;
5624 End;
5625
5626 If FDBProcs.DBType=Native_Oracle7 Then
5627 Begin
5628 If FDBProcs.SQLGetData(ahstmt,1,SQL_C_CHAR,OracleRowId,255,Res)<>SQL_SUCCESS Then
5629 Begin
5630 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5631 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5632 SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5633 End;
5634 End;
5635
5636 FillChar(c1,255,0);
5637 If FDBProcs.SQLGetCursorName(ahstmt,c1,255,resultCols)<>SQL_SUCCESS Then
5638 Begin
5639 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5640 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5641 SQLError('Error executing SQLGetCursorName statement: '+S);
5642 End;
5643
5644 If FDBProcs.DBType=Native_Oracle7 Then ahstmt1:=ahstmt
5645 Else
5646 Begin
5647 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5648 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt1);
5649 End;
5650 S:='DELETE FROM '+TableName;
5651 Case FDBProcs.DBType Of
5652 Native_mSQL: S:=S+' WHERE _rowid='+tostr(RowId);
5653 Native_Oracle7: S:=S+' WHERE ROWID='+#39+OracleRowId+#39;
5654 Else S:=S+' WHERE CURRENT OF '+c1;
5655 End;
5656 C:=S;
5657
5658 If FDBProcs.SQLExecDirect(ahstmt1,C,SQL_NTS)<>SQL_SUCCESS Then
5659 Begin
5660 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt1);
5661 FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5662 SQLError('Error executing SQL DELETE statement: '+S);
5663 End;
5664
5665 FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5666 LeaveSQLProcessing;
5667
5668 Inherited DoDelete;
5669End;
5670
5671
5672Procedure TTable.CommitInsert(Commit:Boolean);
5673Var ahstmt:SQLHSTMT;
5674 Ansi:AnsiString;
5675 S:String;
5676 T:LongInt;
5677 Field:TField;
5678 i:LongInt;
5679Begin
5680 Inherited CommitInsert(Commit);
5681
5682 If ReadOnly Then SQLError('Cannot modify a readonly dataset!');
5683
5684 If Commit Then
5685 Begin
5686 EnterSQLProcessing;
5687 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5688
5689 Ansi:='INSERT INTO '+TableName+' (';
5690 For T:=0 To FieldCount-1 Do
5691 Begin
5692 Ansi:=Ansi+FieldNames[T];
5693 If T<>FieldCount-1 Then Ansi:=Ansi+',';
5694 End;
5695
5696 Ansi:=Ansi+') VALUES(';
5697 For T:=0 To FieldCount-1 Do
5698 Begin
5699 Field:=Fields[T];
5700 If Field.DataType=ftMemo Then Ansi:=Ansi+#39+PChar(Field.FValue)^+#39
5701 Else
5702 Begin
5703 S:=Field2String(field);
5704 Ansi:=Ansi+S;
5705 End;
5706 If T<>FieldCount-1 Then Ansi:=Ansi+',';
5707 End;
5708 Ansi:=Ansi+')';
5709
5710 //ErrorBox2(PChar(Ansi)^);
5711 If FDBProcs.SQLExecDirect(ahstmt,PChar(Ansi)^,SQL_NTS)<>SQL_SUCCESS Then
5712 Begin
5713 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5714 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5715 SQLError('Error executing INSERT SQL statement: '+S);
5716 End;
5717
5718 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5719 LeaveSQLProcessing;
5720
5721 FRowIsInserted:=False;
5722 QueryTable;
5723 End
5724 Else
5725 Begin
5726 RemoveCurrentFields;
5727
5728 RowInserted := False;
5729 End;
5730End;
5731
5732
5733Function TTable.UpdateFieldSelect(Field:TField):Boolean;
5734Var ahstmt,ahstmt1:SQLHSTMT;
5735 resultCols:SQLSMALLINT;
5736 C,c1:cstring;
5737 rc:SQLRETURN;
5738 S:String;
5739 T,T1,RowId:LongInt;
5740 Res:SQLINTEGER;
5741 Ansi:AnsiString;
5742 OracleRowId:CString;
5743Begin
5744 Result:=False;
5745 If Not FOpened Then Exit;
5746 If ((field=Nil)Or(FSelect.Count=0)) Then Exit;
5747 If FRowIsInserted Then
5748 Begin
5749 Result:=True;
5750 Exit;
5751 End;
5752
5753 If ReadOnly Then SQLError('Cannot modify a readonly dataset!');
5754 If (Not IsTable) Then exit; //cannot update this result set...
5755
5756 EnterSQLProcessing;
5757 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5758
5759 Case FDBProcs.DBType Of
5760 Native_mSQL: C:='SELECT _rowid,'+Field.FieldName+' FROM '+TableName;
5761 Native_Oracle7: C:='SELECT ROWID,'+Field.FieldName+' FROM '+TableName+' FOR UPDATE';
5762 Else C:='SELECT * FROM '+TableName+' FOR UPDATE';
5763 End;
5764
5765 If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then
5766 Begin
5767 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5768 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5769 SQLError('Error executing SELECT SQL statement: '+S);
5770 End;
5771
5772 FDBProcs.SQLNumResultCols(ahstmt,resultCols);
5773 If resultCols=0 Then //Not A Select statement
5774 Begin
5775 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5776 LeaveSQLProcessing;
5777 Exit;
5778 End;
5779
5780 If FDBProcs.DBType=Native_mSQL Then T1:=Field.FRow-1
5781 Else T1:=Field.FRow;
5782
5783 For T:=0 To T1 Do
5784 Begin
5785 rc:=FDBProcs.SQLFetch(ahstmt);
5786 If ((rc=SQL_NO_DATA_FOUND)Or(rc=SQL_ERROR)) Then
5787 Begin
5788 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5789 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5790 SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5791 End;
5792 End;
5793
5794 If FDBProcs.DBType=Native_mSQL Then
5795 Begin
5796 If FDBProcs.SQLGetData(ahstmt,1,SQL_INTEGER,RowId,4,Res)<>SQL_SUCCESS Then
5797 Begin
5798 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5799 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5800 SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5801 End;
5802 End;
5803
5804 If FDBProcs.DBType=Native_Oracle7 Then
5805 Begin
5806 If FDBProcs.SQLGetData(ahstmt,1,SQL_C_CHAR,OracleRowId,255,Res)<>SQL_SUCCESS Then
5807 Begin
5808 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5809 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5810 SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5811 End;
5812 End;
5813
5814 FillChar(c1,255,0);
5815 If FDBProcs.SQLGetCursorName(ahstmt,c1,255,resultCols)<>SQL_SUCCESS Then
5816 Begin
5817 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5818 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5819 SQLError('Error executing SQLGetCursorName statement: '+S);
5820 End;
5821
5822 If FDBProcs.DBType=Native_Oracle7 Then ahstmt1:=ahstmt
5823 Else
5824 Begin
5825 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5826 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt1);
5827 End;
5828
5829 Ansi:='UPDATE '+TableName+' SET '+field.FieldName+'=';
5830 If Field.DataType=ftMemo Then Ansi:=Ansi+#39+PChar(Field.FValue)^+#39
5831 Else Ansi:=Ansi+Field2String(field);
5832
5833 Case FDBProcs.DBType Of
5834 Native_mSQL: Ansi:=Ansi+' WHERE _rowid='+tostr(RowId);
5835 Native_Oracle7: Ansi:=Ansi+' WHERE ROWID='+#39+OracleRowId+#39;
5836 Else Ansi:=Ansi+' WHERE CURRENT OF '+c1;
5837 End;
5838
5839 If FDBProcs.SQLExecDirect(ahstmt1,PChar(Ansi)^,SQL_NTS)<>SQL_SUCCESS Then
5840 Begin
5841 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt1);
5842 FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5843 SQLError('Error executing SQL UPDATE statement: '+S);
5844 End;
5845
5846 FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5847 LeaveSQLProcessing;
5848 Result:=True;
5849End;
5850
5851
5852Procedure TTable.DoCancel;
5853Begin
5854 FDBProcs.SQLTransact(FDBProcs.ahenv,FDBProcs.ahdbc,SQL_ROLLBACK);
5855End;
5856
5857
5858Procedure TTable.DoPost;
5859Begin
5860 FDBProcs.SQLTransact(FDBProcs.ahenv,FDBProcs.ahdbc,SQL_COMMIT);
5861End;
5862
5863
5864Procedure TTable.CloseStmt;
5865Var I:LongInt;
5866Begin
5867 If Not FOpened Then Exit;
5868
5869 {Free statement Handle}
5870 If FDBProcs.ahstmt<>0 Then
5871 Begin
5872 FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP);
5873 FDBProcs.ahstmt:=0;
5874 End;
5875End;
5876
5877
5878Procedure TTable.UpdateIndexDefs;
5879Var
5880 ahstmt:SQLHSTMT;
5881 cols:SQLSMALLINT;
5882 I:LongInt;
5883 C:Array[0..9] Of cstring;
5884 OutLen:Array[0..9] Of SQLINTEGER;
5885 rc:SQLRETURN;
5886 S,S1,Fields:String;
5887 OldActive:Boolean;
5888 OldOpen:Boolean;
5889 IndexDef:TIndexDef;
5890Begin
5891 If FIndexDefs<>Nil Then FIndexDefs.Clear
5892 Else FIndexDefs.Create(Self);
5893 If FIndexFieldMap<>Nil Then FIndexFieldMap.Clear;
5894
5895 If (Not IsTable) Then SQLError('Illegal operation');
5896
5897 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
5898 Begin
5899 OldActive:=FActive;
5900 OldOpen:=FOpened;
5901 If Not FOpened Then
5902 Begin
5903 FActive:=True;
5904 DoOpen;
5905 If Not FOpened Then Active:=False;
5906 End;
5907
5908 If FOpened Then
5909 If @FDBProcs.SQLStatistics<>Nil Then
5910 Begin
5911 EnterSQLProcessing;
5912 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5913
5914 If FDBProcs.SQLStatistics(ahstmt,Nil,0,Nil,0,TableName,SQL_NTS,SQL_INDEX_ALL,SQL_ENSURE)=SQL_SUCCESS Then
5915 Begin
5916 FDBProcs.SQLNumResultCols(ahstmt,cols);
5917 If cols>9 Then cols:=9;
5918 For I := 0 To cols-1 Do
5919 FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
5920
5921 rc:=FDBProcs.SQLFetch(ahstmt);
5922 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
5923 Begin
5924 If OutLen[5]<>SQL_NULL_DATA Then
5925 Begin
5926 Move(C[5],S[1],OutLen[5]);
5927 S[0]:=Chr(OutLen[5]);
5928 If S[length(s)]=#0 Then
5929 If length(S)>0 Then dec(S[0]);
5930 If OutLen[4]<>SQL_NULL_DATA Then
5931 Begin
5932 Move(C[4],S1[1],OutLen[4]);
5933 S1[0]:=Chr(OutLen[4]);
5934 If S1[length(S1)]=#0 Then
5935 If length(S1)>0 Then dec(S1[0]);
5936 If S1<>'' Then S:=S1+'.'+S;
5937 End;
5938
5939 //get column name
5940 If OutLen[8]<>SQL_NULL_DATA Then
5941 Begin
5942 Move(C[8],Fields[1],OutLen[8]);
5943 Fields[0]:=Chr(OutLen[8]);
5944 If Fields[length(Fields)]=#0 Then
5945 If length(Fields)>0 Then dec(Fields[0]);
5946 End;
5947
5948 If ((s<>'')And(Fields<>'')) Then
5949 Begin
5950 If FIndexDefs.IndexOf(s)>=0 Then
5951 Begin
5952 IndexDef:=FIndexDefs.Items[FIndexDefs.IndexOf(s)];
5953 AssignStr(IndexDef.FFields,IndexDef.Fields+';'+Fields);
5954 End
5955 Else FIndexDefs.Add(s,Fields,[]);
5956 End;
5957 End;
5958 rc:=FDBProcs.SQLFetch(ahstmt);
5959 End;
5960 End
5961 Else
5962 Begin
5963 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5964 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5965 DataBaseError(s);
5966 End;
5967
5968 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5969 LeaveSQLProcessing;
5970 End;
5971
5972 If Not OldOpen Then DoClose;
5973 FActive:=OldActive;
5974 End;
5975End;
5976
5977Procedure TTable.UpdateFieldDefs;
5978Begin
5979 QueryTable;
5980End;
5981
5982Procedure TTable.QueryTable;
5983Var
5984 resultCols:SQLSMALLINT;
5985 colName:cstring;
5986 colNameLen:SQLSMALLINT;
5987 colType:SQLSMALLINT;
5988 Size:SQLUINTEGER;
5989 Scale:SQLSMALLINT;
5990 I:LongInt;
5991 S:String;
5992 Select:PChar;
5993 Temp:TStringList;
5994 t2:String;
5995 J,j1:String;
5996 First:Boolean;
5997 B:Byte;
5998 field:TField;
5999 MasterTable:TTable;
6000 rc:SQLRETURN;
6001 pfNullable:SQLSMALLINT;
6002 FieldDef:TFieldDef;
6003Label lll;
6004Begin
6005 If Not FOpened Then Exit;
6006
6007 //Erase All tables And Reset Object
6008 CloseStmt;
6009 FFieldDefs.Clear;
6010 FCurrentRow:=-1;
6011 FCurrentField:=0;
6012
6013 If ((Self Is TTable)And(TTable(Self).FMasterSource<>Nil)And
6014 (TTable(Self).FMasterSource.DataSet Is TTable)) Then
6015 Begin
6016 Temp.Create;
6017
6018 t2:=TTable(TTable(Self).FMasterSource.DataSet).TableName;
6019 Temp.Add('SELECT * FROM '+TableName);
6020
6021 S:=TTable(Self).MasterFields;
6022 First:=True;
6023 MasterTable:=TTable(TTable(Self).FMasterSource.DataSet);
6024 While S<>'' Do
6025 Begin
6026 B:=Pos(';',S);
6027 If B<>0 Then
6028 Begin
6029 J:=Copy(S,1,B-1);
6030 System.Delete(S,1,B);
6031 End
6032 Else
6033 Begin
6034 J:=S;
6035 S:='';
6036 End;
6037
6038 B:=Pos('=',J);
6039 If B<>0 Then
6040 Begin
6041 j1:=System.Copy(J,B+1,255);
6042 J[0]:=Chr(B-1);
6043 End
6044 Else j1:=J;
6045
6046 field:=MasterTable.FieldFromColumnName[j1];
6047 If field=Nil Then
6048 Begin
6049 Temp.Destroy;
6050 Goto lll;
6051 End;
6052
6053 j1:=Field2String(field);
6054
6055 If First Then Temp.Add('WHERE '+J+'='+j1)
6056 Else Temp.Add('AND '+J+'='+j1);
6057 First:=False;
6058 End;
6059 Select:=Temp.GetText;
6060
6061 Temp.Destroy;
6062 End
6063 Else
6064 Begin
6065lll:
6066 Select:=FSelect.GetText;
6067 End;
6068
6069 If Select=Nil Then
6070 Begin
6071 DoClose;
6072 Exit;
6073 End;
6074
6075 While ((Select^<>'')And(Select^[length(Select^)-1] In [#13,#10])) Do
6076 Select^[length(Select^)-1]:=#0;
6077
6078 EnterSQLProcessing;
6079 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
6080
6081 Try
6082 If FDBProcs.SQLExecDirect(FDBProcs.ahstmt,Select^,SQL_NTS)<>SQL_SUCCESS Then
6083 Begin
6084 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
6085 CloseStmt;
6086 DoClose;
6087 SQLError('Error executing SELECT statement: '+S);
6088 End;
6089
6090 {The driver determines the number of rows in the result set}
6091 rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
6092 FMaxRows:=0;
6093 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
6094 Begin
6095 inc(FMaxRows);
6096 rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
6097 End;
6098 FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP);
6099 FDBProcs.ahstmt:=0;
6100
6101 {The driver recreates the result set}
6102 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
6103 FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN);
6104 If FDBProcs.SQLExecDirect(FDBProcs.ahstmt,Select^,SQL_NTS)<>SQL_SUCCESS Then
6105 Begin
6106 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
6107 CloseStmt;
6108 DoClose;
6109 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
6110 End;
6111
6112 {The driver determines the result set columns}
6113 FDBProcs.SQLNumResultCols(FDBProcs.ahstmt,resultCols);
6114 If resultCols=0 Then //Not A Select statement
6115 Begin
6116 CloseStmt;
6117 SQLError(LoadNLSStr(SEmptyResultSet));
6118 End
6119 Else
6120 Begin
6121 {Store Result Columns}
6122 For I := 0 To resultCols-1 Do
6123 Begin
6124 Size:=0;
6125 FDBProcs.SQLDescribeCol(FDBProcs.ahstmt, I + 1, colName,
6126 SizeOf(colName), colNameLen, colType, Size, Scale, pfNullable);
6127 If Size>65535 Then Size:=4096;
6128 S:=colName;
6129
6130 Case ColType Of
6131 SQL_REAL:Size:=4;
6132 SQL_FLOAT,SQL_DOUBLE,SQL_NUMERIC:Size:=8;
6133 End; //case
6134
6135 FFieldDefs.Add(S, MapSQLType(colType), Size, pfNullable=SQL_NO_NULLS);
6136
6137 FieldDef := FFieldDefs[I];
6138 FieldDef.Precision := Scale;
6139 End;
6140
6141 FCurrentRow:=0; {First Row}
6142 FCurrentField:=0; {First field}
6143 End;
6144
6145 Post; //Commit All transactions Until here
6146 StrDispose(Select);
6147 LeaveSQLProcessing;
6148 Except
6149 ON E:ESQLError Do
6150 Begin
6151 StrDispose(Select);
6152 CloseStmt;
6153 LeaveSQLProcessing;
6154 ErrorBox(E.Message);
6155 End;
6156 Else
6157 Begin
6158 StrDispose(Select);
6159 CloseStmt;
6160 LeaveSQLProcessing;
6161 Raise;
6162 End;
6163 End;
6164
6165 DataChange(deDataBaseChanged);
6166End;
6167
6168
6169{
6170ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6171º º
6172º Speed-Pascal/2 Version 2.0 º
6173º º
6174º Speed-Pascal Component Classes (SPCC) º
6175º º
6176º This section: TQuery Class Implementation º
6177º º
6178º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6179º º
6180ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6181}
6182
6183Procedure TQuery.RefreshTable;
6184Begin
6185 If ((ComponentState*[csReading]<>[])Or(FDataSetLocked)) Then
6186 Begin
6187 FRefreshOnLoad:=FActive;
6188 Exit;
6189 End;
6190 DoOpen;
6191 If Not FOpened Then Exit;
6192 If FSelect.Count<>0 Then QueryTable;
6193End;
6194
6195Procedure TQuery.SetSQL(NewValue:TStrings);
6196Begin
6197 If ((NewValue=FSelect)Or(NewValue.Equals(FSelect))) Then Exit; {!}
6198 FSelect.Assign(NewValue);
6199 If FActive Then RefreshTable;
6200End;
6201
6202Procedure TQuery.SetupComponent;
6203Begin
6204 Inherited SetupComponent;
6205 ReadOnly:=True;
6206 Name:='Query';
6207End;
6208
6209Function TQuery.WriteSCUResource(Stream:TResourceStream):Boolean;
6210Var aText:PChar;
6211Begin
6212 Result:=Inherited WriteSCUResource(Stream);
6213 If Result=False Then Exit;
6214 aText:=FSelect.GetText;
6215 If aText<>Nil Then
6216 Begin
6217 Result:=Stream.NewResourceEntry(rnDBQuery,aText^,Length(aText^)+1);
6218 StrDispose(aText);
6219 End;
6220End;
6221
6222Procedure TQuery.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
6223Var aText:PChar;
6224Begin
6225 If ResName = rnDBQuery Then
6226 Begin
6227 aText:=@Data;
6228 FSelect.SetText(aText);
6229 End
6230 Else Inherited ReadSCUResource(ResName,Data,DataLen)
6231End;
6232
6233{
6234ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6235º º
6236º Speed-Pascal/2 Version 2.0 º
6237º º
6238º Speed-Pascal Component Classes (SPCC) º
6239º º
6240º This section: TParam Class Implementation º
6241º º
6242º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6243º º
6244ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6245}
6246
6247Procedure TParam.SetAsBCD(Value: Currency);
6248Begin
6249 FNull := False;
6250 FBound := True;
6251 FData:=Value;
6252End;
6253
6254Procedure TParam.SetAsBoolean(Value: Boolean);
6255Begin
6256 FNull := False;
6257 FBound := True;
6258 FData:=Value;
6259End;
6260
6261Procedure TParam.SetAsCurrency(Value:Extended);
6262Begin
6263 FNull := False;
6264 FBound := True;
6265 FData:=Value;
6266End;
6267
6268Procedure TParam.SetAsDate(Value: TDateTime);
6269Begin
6270 FNull := False;
6271 FBound := True;
6272 FData:=Value;
6273End;
6274
6275Procedure TParam.SetAsDateTime(Value: TDateTime);
6276Begin
6277 FNull := False;
6278 FBound := True;
6279 FData:=Value;
6280End;
6281
6282Procedure TParam.SetAsFloat(Const Value:Extended);
6283Begin
6284 FNull := False;
6285 FBound := True;
6286 FData:=Value;
6287End;
6288
6289Procedure TParam.SetAsInteger(Value: Longint);
6290Begin
6291 FNull := False;
6292 FBound := True;
6293 FData:=Value;
6294End;
6295
6296Procedure TParam.SetAsString(Const Value:String);
6297Begin
6298 FNull := False;
6299 FBound := True;
6300 FData:=Value;
6301End;
6302
6303Procedure TParam.SetAsSmallInt(Value: LongInt);
6304Begin
6305 FNull := False;
6306 FBound := True;
6307 FData:=Value;
6308End;
6309
6310Procedure TParam.SetAsTime(Value: TDateTime);
6311Begin
6312 FNull := False;
6313 FBound := True;
6314 FData:=Value;
6315End;
6316
6317Procedure TParam.SetAsVariant(Value: Variant);
6318Begin
6319 FNull := False;
6320 FBound := True;
6321 Case VarType(Value) Of
6322 varByte,varSmallint:DataType:=ftSmallInt;
6323 varInteger,varLongInt,varLongWord:DataType:=ftInteger;
6324 varCurrency:DataType:=ftBCD;
6325 varSingle,varDouble,varExtended:DataType:=ftFloat;
6326 varBoolean:DataType:=ftBoolean;
6327 varString:DataType:=ftString;
6328 Else DataType := ftUnknown;
6329 End;
6330 FData := Value;
6331End;
6332
6333Procedure TParam.SetAsWord(Value: LongInt);
6334Begin
6335 FNull := False;
6336 FBound := True;
6337 FData:=Value;
6338End;
6339
6340Function TParam.GetAsBCD: Currency;
6341Begin
6342 Result:=FData;
6343End;
6344
6345Function TParam.GetAsBoolean: Boolean;
6346Begin
6347 Result:=FData;
6348End;
6349
6350Function TParam.GetAsDateTime: TDateTime;
6351Begin
6352 Result:=FData;
6353End;
6354
6355Function TParam.GetAsFloat:Extended;
6356Begin
6357 Result:=FData;
6358End;
6359
6360Function TParam.GetAsInteger: Longint;
6361Begin
6362 Result:=FData;
6363End;
6364
6365Function TParam.GetAsString:String;
6366Begin
6367 Result:=FData;
6368End;
6369
6370Function TParam.GetAsVariant: Variant;
6371Begin
6372 Result:=FData;
6373End;
6374
6375Function TParam.IsEqual(Value: TParam): Boolean;
6376Begin
6377 result:=False;
6378 If ParamType=Value.ParamType Then
6379 If Bound=Value.Bound Then
6380 If VarType(FData)=VarType(Value.FData) Then
6381 If Name=Value.Name Then
6382 If FData=Value.FData Then result:=True;
6383End;
6384
6385Procedure TParam.SetDataType(Value: TFieldType);
6386Begin
6387 FData := 0;
6388 FDataType := Value;
6389End;
6390
6391Procedure TParam.SetText(Const Value:String);
6392Begin
6393 FNull := False;
6394 FBound := True;
6395 If FDataType=ftUnknown Then DataType:=ftString;
6396 FData := Value;
6397 Case DataType of
6398 ftBoolean:FData:=Boolean(FData);
6399 ftInteger,ftSmallInt,ftWord: FData := Integer(FData);
6400 ftDateTime,ftTime,ftDate:FData:=Extended(FData);
6401 ftBCD:FData:=Currency(FData);
6402 ftCurrency,ftFloat:FData:=Extended(FData);
6403 End;
6404End;
6405
6406Constructor TParam.Create(AParamList:TParams;AParamType: TParamType);
6407Begin
6408 FParamList:=AParamList;
6409 If FParamList<>Nil Then FParamList.AddParam(Self);
6410 FParamType := AParamType;
6411 DataType := ftUnknown;
6412 FBound := False;
6413End;
6414
6415Destructor TParam.Destroy;
6416Begin
6417 If FParamList<>Nil Then FParamList.RemoveParam(Self);
6418 If FName<>Nil Then FreeMem(FName,length(FName^)+1);
6419 Inherited Destroy;
6420End;
6421
6422Function TParam.GetName:String;
6423Begin
6424 If FName=Nil Then result:=''
6425 Else Result:=FName^;
6426End;
6427
6428Procedure TParam.SetName(Const NewValue:String);
6429Begin
6430 If FName<>Nil Then FreeMem(FName,length(FName^)+1);
6431 GetMem(FName,length(NewValue)+1);
6432 FName^:=NewValue;
6433End;
6434
6435Procedure TParam.Assign(Param: TParam);
6436Begin
6437 If Param=Nil Then exit;
6438 DataType:=Param.DataType;
6439 If not Param.IsNull Then
6440 Begin
6441 FNull := False;
6442 FBound := True;
6443 FData := Param.FData;
6444 End
6445 Else Clear;
6446 Name:=Param.Name;
6447 FBound:=Param.Bound;
6448 If FParamType=ptUnknown Then FParamType:=Param.ParamType;
6449End;
6450
6451Procedure TParam.AssignField(Field: TField);
6452Begin
6453 If Field=Nil Then exit;
6454 DataType:=Field.DataType;
6455 If not Field.IsNull Then
6456 Begin
6457 FNull := False;
6458 FBound := True;
6459 FData := Field.AsString;
6460 End
6461 Else Clear;
6462 Name:=Field.FieldName;
6463 FBound:=True;
6464End;
6465
6466Procedure TParam.AssignFieldValue(Field:TField;Const Value: Variant);
6467Begin
6468 If Field=Nil Then exit;
6469 DataType := Field.DataType;
6470 If VarIsNull(Value) Then Clear
6471 Else
6472 Begin
6473 FNull := False;
6474 FBound := True;
6475 FData := Value;
6476 End;
6477 FBound := True;
6478End;
6479
6480Procedure TParam.Clear;
6481Begin
6482 FData:=0;
6483 FNull:=True;
6484End;
6485
6486{
6487ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6488º º
6489º Speed-Pascal/2 Version 2.0 º
6490º º
6491º Speed-Pascal Component Classes (SPCC) º
6492º º
6493º This section: TParams Class Implementation º
6494º º
6495º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6496º º
6497ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6498}
6499
6500Function TParams.GetParam(Index: Word): TParam;
6501Begin
6502 result:=FItems[Index];
6503End;
6504
6505Function TParams.GetParamValue(Const ParamName:String): Variant;
6506Var Param:TParam;
6507Begin
6508 Param:=ParamByName(ParamName);
6509 If Param<>Nil Then Result:=Param.Value;
6510End;
6511
6512Procedure TParams.SetParamValue(Const ParamName:String;Const Value: Variant);
6513Var Param:TParam;
6514Begin
6515 Param:=ParamByName(ParamName);
6516 If Param<>Nil Then Param.Value:=Value;
6517End;
6518
6519Constructor TParams.Create;
6520Begin
6521 Inherited Create;
6522 FItems.Create;
6523End;
6524
6525Destructor TParams.Destroy;
6526Begin
6527 Clear;
6528 FItems.Destroy;
6529 Inherited Destroy;
6530End;
6531
6532Procedure TParams.AddParam(Value: TParam);
6533Begin
6534 FItems.Add(Value);
6535End;
6536
6537Procedure TParams.RemoveParam(Value: TParam);
6538Begin
6539 FItems.Remove(Value);
6540 If Value.FParamList=Self Then Value.FParamList:=Nil;
6541End;
6542
6543Function TParams.CreateParam(FldType:TFieldType;Const ParamName:String;ParamType: TParamType): TParam;
6544Begin
6545 Result.Create(Self,ParamType);
6546 Result.Name:=ParamName;
6547 Result.DataType := FldType;
6548End;
6549
6550Function TParams.Count:LongInt;
6551Begin
6552 Result:=FItems.Count;
6553End;
6554
6555Procedure TParams.Clear;
6556Var t:LongInt;
6557 Param:TParam;
6558Begin
6559 For t:=FItems.Count-1 DownTo 0 Do
6560 Begin
6561 Param:=FItems[t];
6562 Param.Destroy;
6563 End;
6564End;
6565
6566Function TParams.IsEqual(Value:TParams): Boolean;
6567Var t:LongInt;
6568Begin
6569 Result:=False;
6570 If FItems.Count=Value.Count Then
6571 For t:=0 To FItems.Count-1 Do If not Items[t].IsEqual(Value.Items[t]) Then exit;
6572End;
6573
6574Function TParams.ParamByName(Const Value:String):TParam;
6575Var t:LongInt;
6576Begin
6577 For t:=0 To FItems.Count - 1 Do
6578 Begin
6579 Result:=FItems[t];
6580 If Result.Name=Value Then Exit;
6581 End;
6582 DatabaseError('Invalid stored procedure parameter name: '+Value);
6583End;
6584
6585
6586{
6587ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6588º º
6589º Speed-Pascal/2 Version 2.0 º
6590º º
6591º Speed-Pascal Component Classes (SPCC) º
6592º º
6593º This section: TStoredProc Class Implementation º
6594º º
6595º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6596º º
6597ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6598}
6599
6600Function TStoredProc.GetParamCount:Word;
6601Begin
6602 Result:=FParams.Count;
6603End;
6604
6605Procedure TStoredProc.SetDefaultParams;
6606Var
6607 ahstmt:SQLHSTMT;
6608 cols:SQLSMALLINT;
6609 I,t:LongInt;
6610 C:Array[0..12] Of cstring;
6611 OutLen:Array[0..12] Of SQLINTEGER;
6612 si:SQLSMALLINT;
6613 rc:SQLRETURN;
6614 S:String;
6615 Cs:CString;
6616 OldActive:Boolean;
6617 OldOpen:Boolean;
6618 pt:TParamType;
6619 ft:TFieldType;
6620 cc:Integer;
6621 Names:TStringList;
6622 Types,Modes:TList;
6623Label weiter;
6624Begin
6625 //determine parameter from driver
6626 FParams.Clear;
6627
6628 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
6629 If StoredProcName<>'' Then
6630 Begin
6631 OldActive:=FActive;
6632 OldOpen:=FOpened;
6633 If Designed Then
6634 If Not FOpened Then
6635 Begin
6636 FActive:=True;
6637 DoOpen;
6638 If Not FOpened Then Active:=False;
6639 End;
6640
6641 If FOpened Then
6642 Begin
6643 If FDBProcs.DBType=Native_Oracle7 Then
6644 Begin
6645 Names.Create;
6646 Types.Create;
6647 Modes.Create;
6648 If not FDBProcs.Oracle7GetProcParams(FProcName,@FDBProcs,Names,Types,Modes) Then
6649 Begin
6650 ErrorBox(SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt));
6651 End
6652 Else
6653 Begin
6654 For t:=0 To Names.Count-1 Do
6655 Begin
6656 i:=LongInt(Types[t]);
6657 ft:=MapSQLType(i);
6658 i:=LongInt(Modes[t]);
6659 If i>=16 Then pt:=ptResult
6660 Else Case i Of
6661 0:pt:=ptInput;
6662 1:pt:=ptOutput;
6663 Else pt:=ptInputOutput;
6664 End; //case
6665 FParams.CreateParam(ft,Names[t],pt);
6666 End;
6667 End;
6668 Names.Destroy;
6669 Types.Destroy;
6670 Modes.Destroy;
6671 End
6672 Else
6673 Begin
6674 EnterSQLProcessing;
6675 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
6676
6677 Cs:=FProcName;
6678 If FDBProcs.SQLProcedureColumns(ahstmt,Nil,0,Nil,0,Cs,length(FProcName),Nil,0)=SQL_SUCCESS Then
6679 Begin
6680 FDBProcs.SQLNumResultCols(ahstmt,cols);
6681 If cols>13 Then cols:=13;
6682 For I := 0 To cols-1 Do
6683 FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
6684 rc:=FDBProcs.SQLFetch(ahstmt);
6685 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
6686 Begin
6687 If OutLen[3]<>SQL_NULL_DATA Then //Parameter name
6688 Begin
6689 Move(C[4],S[1],OutLen[4]); //Parameter type
6690 S[0]:=Chr(OutLen[4]);
6691 Val(S,si,cc);
6692 If cc<>0 Then goto weiter; //illegal
6693
6694 Case si Of
6695 SQL_PARAM_INPUT:pt:=ptInput;
6696 SQL_PARAM_OUTPUT:pt:=ptOutput;
6697 SQL_PARAM_INPUT_OUTPUT:pt:=ptInputOutput;
6698 SQL_RETURN_VALUE:pt:=ptResult;
6699 SQL_RESULT_COL:pt:=ptResultSet;
6700 Else pt:=ptUnknown;
6701 End;
6702
6703 Move(C[5],S[1],OutLen[5]); //Parameter data type
6704 S[0]:=Chr(OutLen[5]);
6705 Val(S,si,cc);
6706 If cc<>0 Then goto weiter; //illegal
6707
6708 ft:=MapSQLType(si);
6709
6710 Move(C[3],S[1],OutLen[3]);
6711 S[0]:=Chr(OutLen[3]);
6712
6713 FParams.CreateParam(ft,S,pt);
6714 End;
6715weiter:
6716 rc:=FDBProcs.SQLFetch(ahstmt);
6717 End;
6718 End;
6719
6720 FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
6721 LeaveSQLProcessing;
6722 End;
6723 End;
6724
6725 If Designed Then
6726 Begin
6727 If Not OldOpen Then DoClose;
6728 FActive:=OldActive;
6729 End;
6730 End;
6731End;
6732
6733Procedure TStoredProc.SetPrepared(NewValue:Boolean);
6734Begin
6735 If not NewValue Then
6736 Begin
6737 FPrepared:=False;
6738 exit;
6739 End;
6740
6741 If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then DoOpen;
6742
6743 If FOpened Then FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
6744
6745 FPrepared:=True;
6746End;
6747
6748Procedure TStoredProc.SetParams(NewValue:TParams);
6749Var t:LongInt;
6750Begin
6751 FParams.Clear;
6752 For t:=0 To NewValue.Count-1 Do
6753 FParams.CreateParam(NewValue[t].DataType,NewValue[t].Name,NewValue[t].ParamType);
6754End;
6755
6756Procedure TStoredProc.SetStoredProcName(NewValue:String);
6757Begin
6758 CheckInactive;
6759 FProcName:=NewValue;
6760 FParams.Clear;
6761End;
6762
6763Constructor TStoredProc.Create(AOwner: TComponent);
6764Begin
6765 Inherited Create(AOwner);
6766 ReadOnly:=True;
6767 Name:='StoredProc';
6768 FParams.Create;
6769End;
6770
6771Destructor TStoredProc.Destroy;
6772Begin
6773 FParams.Destroy;
6774 Inherited Destroy;
6775End;
6776
6777Procedure TStoredProc.CopyParams(Value:TParams);
6778Begin
6779 Params:=Value;
6780End;
6781
6782Procedure TStoredProc.ExecProc;
6783Var rc:SQLRETURN;
6784 ReturnsResultSet:Boolean;
6785 t:LongInt;
6786 Param:TParam;
6787 s:String;
6788 c:CString;
6789 resultCols:SQLSMALLINT;
6790 I:LongInt;
6791 Size:SQLUINTEGER;
6792 colName:CString;
6793 colNameLen:SQLSMALLINT;
6794 colType:SQLSMALLINT;
6795 Scale:SQLSMALLINT;
6796 FieldDef:TFieldDef;
6797
6798 ptsql,ctype,sqltype,Len:SQLSMALLINT;
6799 p:Pointer;
6800
6801 Function ExecSQL:SQLRETURN;
6802 Var s:String;
6803 c:CString;
6804 t:LongInt;
6805 Begin
6806 If FDBProcs.DBType=Native_Oracle7 Then s:=StoredProcName+'('
6807 Else s:='call '+StoredProcName+'(';
6808 For t:=0 To FParams.Count-1 Do
6809 Begin
6810 Param:=FParams[t];
6811 If Param.ParamType=ptResultSet Then
6812 Begin
6813 ReturnsResultSet:=True;
6814 continue;
6815 End;
6816
6817 If FDBProcs.DBType=Native_Oracle7 Then
6818 Begin
6819 If ((Param.ParamType=ptResult)And(s[1]<>':')) Then s:=':p0='+s
6820 Else
6821 Begin
6822 If s[length(s)]<>'(' Then s:=s+',';
6823 s:=s+':p'+tostr(t+1);
6824 End;
6825 End
6826 Else
6827 Begin
6828 If ((Param.ParamType=ptResult)And(s[1]<>'?')) Then s:='?='+s
6829 Else
6830 Begin
6831 If s[length(s)]<>'(' Then s:=s+',';
6832 s:=s+'?';
6833 End;
6834 End;
6835 End;
6836
6837 If FDBProcs.DBType=Native_Oracle7 Then
6838 s:='BEGIN'+#10+s+');'#10+'END;'
6839 Else
6840 s:='{'+s+')}';
6841 c:=s;
6842 Result:=FDBProcs.SQLExecDirect(FDBProcs.ahstmt,c,SQL_NTS);
6843 End;
6844
6845 Procedure BindParameters;
6846 Var i:LongInt;
6847 Param:TParam;
6848 Begin
6849 For i:=0 To FParams.Count-1 Do
6850 Begin
6851 Param:=FParams[i];
6852
6853 Case Param.ParamType Of
6854 ptInput:ptsql:=SQL_PARAM_INPUT;
6855 ptOutput:ptsql:=SQL_PARAM_OUTPUT;
6856 ptResult:
6857 Begin
6858 If FDBProcs.DBType=Native_Oracle7 Then ptsql:=SQL_PARAM_RESULT
6859 Else ptsql:=SQL_PARAM_OUTPUT;
6860 End;
6861 ptInputOutput:ptsql:=SQL_PARAM_INPUT_OUTPUT;
6862 Else Continue; //Next Parameter
6863 End;
6864
6865 Case Param.DataType Of
6866 ftString:
6867 Begin
6868 sqlType:=SQL_CHAR;
6869 cType:=SQL_C_CHAR;
6870 p:=@Param.FResultNTS;
6871 Param.FResultNTS:=Param.AsString;
6872 Len:=Length(Param.FResultNTS);
6873 Param.FOutLen:=SQL_NTS;
6874 End;
6875 ftCurrency:
6876 Begin
6877 sqlType:=SQL_NUMERIC;
6878 cType:=SQL_C_FLOAT;
6879 Len:=10;
6880 p:=@Param.FResultExtended;
6881 Param.FResultExtended:=Param.AsFloat;
6882 Param.FOutLen:=10;
6883 End;
6884 ftInteger:
6885 Begin
6886 sqlType:=SQL_INTEGER;
6887 cType:=SQL_C_LONG;
6888 Len:=4;
6889 p:=@Param.FResultLongInt;
6890 Param.FResultLongInt:=Param.AsInteger;
6891 Param.FOutLen:=4;
6892 End;
6893 ftSmallInt:
6894 Begin
6895 sqlType:=SQL_SMALLINT;
6896 cType:=SQL_C_SHORT;
6897 Len:=2;
6898 p:=@Param.FResultSmallInt;
6899 Param.FResultSmallInt:=Param.AsSmallInt;
6900 Param.FOutLen:=2;
6901 End;
6902 ftFloat:
6903 Begin
6904 sqlType:=SQL_FLOAT;
6905 cType:=SQL_C_FLOAT;
6906 Len:=10;
6907 p:=@Param.FResultExtended;
6908 Param.FResultExtended:=Param.AsFloat;
6909 Param.FOutLen:=10;
6910 End;
6911 ftDate:
6912 Begin
6913 sqlType:=SQL_DATE;
6914 cType:=SQL_C_DATE;
6915 Len:=sizeof(Param.FResultDate);
6916 p:=@Param.FResultDate;
6917 DecodeDate(Param.AsDate,Param.FResultDate.Year,Param.FResultDate.Month,Param.FResultDate.Day);
6918 Param.FOutLen:=sizeof(Param.FResultDate);
6919 End;
6920 ftTime:
6921 Begin
6922 sqlType:=SQL_TIME;
6923 cType:=SQL_C_TIME;
6924 Len:=sizeof(Param.FResultTime);
6925 p:=@Param.FResultTime;
6926 RoundDecodeTime(Param.AsTime,Param.FResultTime.Hour,Param.FResultTime.Minute,Param.FResultTime.Second);
6927 Param.FOutLen:=sizeof(Param.FResultTime);
6928 End;
6929 ftDateTime:
6930 Begin
6931 sqlType:=SQL_TIMESTAMP;
6932 cType:=SQL_C_TIMESTAMP;
6933 Len:=sizeof(Param.FResultDateTime);
6934 p:=@Param.FResultDateTime;
6935 DecodeDate(Param.AsDate,Param.FResultDateTime.Year,Param.FResultDateTime.Month,Param.FResultDateTime.Day);
6936 RoundDecodeTime(Param.AsTime,Param.FResultDateTime.Hour,Param.FResultDateTime.Minute,Param.FResultDateTime.Second);
6937 Param.FOutLen:=sizeof(Param.FResultDateTime);
6938 End;
6939 ftMemo:
6940 Begin
6941 sqlType:=SQL_LONGVARCHAR;
6942 cType:=SQL_C_CHAR;
6943 Len:=0; //??
6944 p:=Nil; //???
6945 Param.FOutLen:=0; //?? current len
6946 End;
6947 ftBlob:
6948 Begin
6949 sqlType:=SQL_VARBINARY;
6950 cType:=SQL_C_BINARY;
6951 Len:=0; //??
6952 p:=Nil; //???
6953 Param.FOutLen:=0; //?? current len
6954 End;
6955 ftGraphic:
6956 Begin
6957 sqlType:=SQL_VARGRAPHIC;
6958 cType:=SQL_C_BINARY;
6959 Len:=0; //??
6960 p:=Nil; //???
6961 Param.FOutLen:=0; //?? current len
6962 End;
6963 End; //case
6964
6965 Try
6966 rc:=FDBProcs.SQLBindParameter(FDBProcs.ahstmt,i+1,ptsql,ctype,sqltype,Len,0,p^,Len,Param.FOutLen);
6967 If rc=SQL_ERROR Then
6968 Begin
6969 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
6970 CloseStmt;
6971 DoClose;
6972 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
6973 End;
6974
6975 Except
6976 ON E:ESQLError Do
6977 Begin
6978 CloseStmt;
6979 ErrorBox(E.Message);
6980 End;
6981 Else
6982 Begin
6983 CloseStmt;
6984 Raise;
6985 End;
6986 End;
6987 If FDBProcs.ahstmt=0 Then
6988 Begin
6989 DoClose;
6990 exit;
6991 End;
6992 End;
6993 End;
6994Label err;
6995Begin
6996 If not Prepared Then Prepare;
6997
6998 CloseStmt; //if previous proc returned a result set...
6999 FMaxRows:=0;
7000 If not FOpened Then DoOpen;
7001
7002 If FOpened Then
7003 Begin
7004 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
7005 If FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN)=SQL_ERROR THEN
7006 Begin
7007 //S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
7008 //ErrorBox(S);
7009 End;
7010 End
7011 Else exit;
7012
7013 If FDBProcs.DBType=Native_Oracle7 Then
7014 Begin
7015 rc:=ExecSQL;
7016 If rc=SQL_ERROR Then goto err;
7017 End;
7018
7019 //Bind Parameters
7020 BindParameters;
7021 If FDBProcs.ahstmt=0 Then
7022 Begin
7023 DoClose;
7024 exit;
7025 End;
7026
7027 FFieldDefs.Clear;
7028 FCurrentRow:=-1;
7029 FCurrentField:=0;
7030
7031 ReturnsResultSet:=False;
7032
7033 EnterSQLProcessing;
7034 If FDBProcs.DBType<>Native_Oracle7 Then rc:=ExecSQL
7035 Else rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
7036
7037 If rc<>SQL_ERROR Then
7038 Begin
7039 For i:=0 To FParams.Count-1 Do
7040 Begin
7041 Param:=FParams[i];
7042
7043 If Param.ParamType<>ptOutput Then
7044 If Param.ParamType<>ptInputOutput Then
7045 If Param.ParamType<>ptResult Then continue;
7046
7047 Case Param.DataType Of
7048 ftString:
7049 Begin
7050 Param.AsString:=Param.FResultNTS;
7051 End;
7052 ftCurrency:
7053 Begin
7054 Param.AsFloat:=Param.FResultExtended;
7055 End;
7056 ftInteger:
7057 Begin
7058 Param.AsInteger:=Param.FResultLongInt;
7059 End;
7060 ftSmallInt:
7061 Begin
7062 Param.AsSmallInt:=Param.FResultSmallInt;
7063 End;
7064 ftFloat:
7065 Begin
7066 Param.AsFloat:=Param.FResultExtended;
7067 End;
7068 ftDate:
7069 Begin
7070 Param.AsDate:=EncodeDate(Param.FResultDate.Year,Param.FResultDate.Month,Param.FResultDate.Day);
7071 End;
7072 ftTime:
7073 Begin
7074 Param.AsTime:=EncodeTime(Param.FResultTime.Hour,Param.FResultTime.Minute,Param.FResultTime.Second,0);
7075 End;
7076 ftDateTime:
7077 Begin
7078 Param.AsDateTime:=EncodeDate(Param.FResultDateTime.Year,Param.FResultDateTime.Month,Param.FResultDateTime.Day) +
7079 EncodeTime(Param.FResultDateTime.Hour,Param.FResultDateTime.Minute,Param.FResultDateTime.Second, 0);
7080 End;
7081 ftMemo:
7082 Begin
7083 End;
7084 ftBlob:
7085 Begin
7086 End;
7087 ftGraphic:
7088 Begin
7089 End;
7090 End; //case
7091 End; //for
7092
7093 If ReturnsResultSet Then
7094 Begin
7095 {The driver determines the number of rows in the result set}
7096 rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
7097 FMaxRows:=0;
7098 While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
7099 Begin
7100 inc(FMaxRows);
7101 rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
7102 End;
7103 FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP);
7104 FDBProcs.ahstmt:=0;
7105
7106 {The driver recreates the result set}
7107 FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
7108 If FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN)=SQL_ERROR THEN
7109 Begin
7110 //S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
7111 //ErrorBox(S);
7112 End;
7113 BindParameters;
7114 If FDBProcs.ahstmt=0 Then
7115 Begin
7116 DoClose;
7117 LeaveSQLProcessing;
7118 exit;
7119 End;
7120
7121 rc:=FDBProcs.SQLExecDirect(FDBProcs.ahstmt,c,SQL_NTS);
7122 If rc=SQL_ERROR Then goto err;
7123
7124 Try
7125 FDBProcs.SQLNumResultCols(FDBProcs.ahstmt,resultCols);
7126 If resultCols=0 Then //Not A Select statement
7127 Begin
7128 CloseStmt;
7129 SQLError(LoadNLSStr(SEmptyResultSet));
7130 End
7131 Else
7132 Begin
7133 {Store Result Columns}
7134 For I := 0 To resultCols-1 Do
7135 Begin
7136 Size:=0;
7137 FDBProcs.SQLDescribeCol(FDBProcs.ahstmt, I + 1, colName,
7138 SizeOf(colName), colNameLen, colType, Size, Scale, Nil);
7139 If Size>65535 Then Size:=4096;
7140 S:=colName;
7141
7142 Case ColType Of
7143 SQL_REAL:Size:=4;
7144 SQL_FLOAT,SQL_DOUBLE,SQL_NUMERIC:Size:=8;
7145 End; //case
7146
7147 FFieldDefs.Add(S, MapSQLType(colType), Size, False);
7148
7149 FieldDef := FFieldDefs[I];
7150 FieldDef.Precision := Scale;
7151 End;
7152
7153 FCurrentRow:=0; {First Row}
7154 FCurrentField:=0; {First field}
7155 End;
7156
7157 Post; //Commit All transactions Until here
7158 DataChange(deDataBaseChanged);
7159 Except
7160 ON E:ESQLError Do
7161 Begin
7162 CloseStmt;
7163 LeaveSQLProcessing;
7164 ErrorBox(E.Message);
7165 End;
7166 Else
7167 Begin
7168 CloseStmt;
7169 LeaveSQLProcessing;
7170 Raise;
7171 End;
7172 End;
7173
7174 //for result sets the statement must remain open...
7175 End
7176 Else CloseStmt;
7177
7178 LeaveSQLProcessing;
7179 End
7180 Else
7181 Begin
7182err:
7183 LeaveSQLProcessing;
7184 Try
7185 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
7186 CloseStmt;
7187 SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
7188 Except
7189 ON E:ESQLError Do
7190 Begin
7191 CloseStmt;
7192 ErrorBox(E.Message);
7193 End;
7194 Else
7195 Begin
7196 CloseStmt;
7197 Raise;
7198 End;
7199 End;
7200 End;
7201End;
7202
7203Function TStoredProc.ParamByName(Const Value:String):TParam;
7204Begin
7205 Result := FParams.ParamByName(Value);
7206End;
7207
7208Procedure TStoredProc.Prepare;
7209Begin
7210 If FParams.Count=0 Then SetDefaultParams;
7211 Prepared:=True;
7212End;
7213
7214
7215Procedure TStoredProc.UnPrepare;
7216Begin
7217 Prepared:=False;
7218End;
7219
7220
7221Procedure TStoredProc.DoOpen;
7222Var rc:SQLRETURN;
7223 S:String;
7224Begin
7225 If Not FActive Then Exit;
7226
7227 If Not FillDBProcs(FDBProcs) Then
7228 Begin
7229 ErrorBox(LoadNLSStr(SErrLoadingDB));
7230 Active:=False;
7231 Exit; {Error}
7232 End;
7233 FDBProcs.IsStoredProc:=True;
7234
7235 If Not FOpened Then
7236 Begin
7237 Try
7238 If FBeforeOpen<>Nil Then FBeforeOpen(Self);
7239
7240 FDBProcs.ahstmt:=0;
7241 FDBProcs.ahenv:=0;
7242 If AllocateDBEnvironment(FDBProcs)<>SQL_SUCCESS Then
7243 Begin
7244 ErrorBox(LoadNLSStr(SErrAllocDBEnv)+'.'+
7245 SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
7246 Active:=False;
7247 Exit;
7248 End;
7249
7250 {Connect To Server}
7251 FDBProcs.ahdbc:=0;
7252 If FDBProcs.SQLAllocConnect(FDBProcs.ahenv,FDBProcs.ahdbc)<>SQL_SUCCESS Then
7253 Begin
7254 ErrorBox(LoadNLSStr(SErrAllocDBConnect)+'.'+
7255 SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
7256 DoClose;
7257 Exit;
7258 End;
7259
7260 {Set autocommit OFF}
7261 If FDBProcs.SQLSetConnectOption(FDBProcs.ahdbc,SQL_AUTOCOMMIT,SQL_AUTOCOMMIT_OFF)<>SQL_SUCCESS Then
7262 Begin
7263 ErrorBox(LoadNLSStr(SErrSettingDBOpts)+'.'+
7264 SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
7265 DoClose;
7266 Exit;
7267 End;
7268
7269 {Connect}
7270 Try
7271 If FDBProcs.uid='' Then
7272 Begin
7273 If FDBProcs.pwd='' Then
7274 rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7275 Nil,0,Nil,0)
7276 Else
7277 rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7278 Nil,0,FDBProcs.pwd,SQL_NTS);
7279 End
7280 Else If FDBProcs.pwd='' Then
7281 Begin
7282 rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7283 FDBProcs.uid,SQL_NTS,Nil,0);
7284 End
7285 Else rc:= FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7286 FDBProcs.uid,SQL_NTS,FDBProcs.pwd,SQL_NTS);
7287 If rc<>SQL_SUCCESS Then
7288 Begin
7289 S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0);
7290 DoClose;
7291 SQLError(LoadNLSStr(SErrorDBConnecting)+' "'+DataBase+'".'+#13#10+S);
7292 End;
7293 Except
7294 ON E:ESQLError Do
7295 Begin
7296 ErrorBox(E.Message);
7297 Exit;
7298 End;
7299 Else Raise;
7300 End;
7301
7302 FOpened:=True;
7303 If FAfterOpen<>Nil Then AfterOpen(Self);
7304
7305 If FParams.Count=0 Then SetDefaultParams;
7306 Except
7307 Raise;
7308 End;
7309 End;
7310End;
7311
7312
7313Procedure TStoredProc.DoClose;
7314Var OldOpened:Boolean;
7315Begin
7316 Try
7317 If FBeforeClose<>Nil Then FBeforeClose(Self);
7318
7319 OldOpened:=FOpened;
7320 TDataSet.DoClose;
7321 FOpened:=OldOpened;
7322
7323 If FOpened Then
7324 Begin
7325 CloseStmt;
7326 Post; //Commit All transactions
7327 End;
7328
7329 FActive:=False;
7330 FDataSetLocked:=True;
7331 FFieldDefs.Clear;
7332
7333 FDataSetLocked:=False;
7334
7335 If FDBProcs.ahdbc<>0 Then
7336 Begin
7337 If FOpened Then
7338 If FDBProcs.SQLDisconnect(FDBProcs.ahdbc)<>SQL_SUCCESS Then
7339 ErrorBox('Disconnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
7340 If FDBProcs.SQLFreeConnect(FDBProcs.ahdbc)<>SQL_SUCCESS Then
7341 ErrorBox('FreeConnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
7342 FDBProcs.ahdbc:=0;
7343 End;
7344
7345 If FDBProcs.ahenv<>0 Then
7346 Begin
7347 If FDBProcs.SQLFreeEnv(FDBProcs.ahenv)<>SQL_SUCCESS Then
7348 ErrorBox('FreeEnv error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
7349 FDBProcs.ahenv:=0;
7350 End;
7351
7352 FOpened:=False;
7353 DataChange(deDataBaseChanged);
7354
7355 If FAfterClose<>Nil Then FAfterClose(Self);
7356 Except
7357 Raise;
7358 End;
7359End;
7360
7361
7362Procedure TStoredProc.Loaded;
7363Var OldOpen,OldActive:Boolean;
7364Begin
7365 Inherited Loaded;
7366
7367 OldOpen:=FOpened;
7368 OldActive:=FActive;
7369 FActive:=True;
7370 DoOpen;
7371 If not OldOpen Then DoClose;
7372 FActive:=OldActive;
7373End;
7374
7375
7376Procedure TStoredProc.Delete;
7377Begin
7378End;
7379
7380
7381Procedure TStoredProc.Insert;
7382Begin
7383End;
7384
7385
7386Procedure TStoredProc.InsertRecord(Const values:Array Of Const);
7387Begin
7388 Try
7389 FDataChangeLock:=True;
7390 Insert;
7391 Finally
7392 FDataChangeLock:=False;
7393 End;
7394 SetFields(values);
7395End;
7396
7397
7398Function TStoredProc.UpdateFieldSelect(field:TField):Boolean;
7399Begin
7400 Result:=False;
7401End;
7402
7403
7404
7405Begin
7406End.
7407
Note: See TracBrowser for help on using the repository browser.