source: trunk/Sibyl/SPCC/CLASSES.PAS@ 7

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

+ sibyl staff
  • Property svn:eol-style set to native
File size: 220.2 KB
Line 
1
2{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3 º º
4 º Sibyl Portable Component Classes º
5 º º
6 º Copyright (C) 1995,97 SpeedSoft Germany, All rights reserved. º
7 º º
8 ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ}
9
10Unit Classes;
11
12
13Interface
14
15Uses Dos,SysUtils;
16
17{$IFDEF OS2}
18Uses PmWin,BseDos;
19{$ENDIF}
20{$IFDEF Win95}
21Uses WinUser,WinBase;
22{$ENDIF}
23
24//TStream Seek origins
25Const
26 soFromBeginning = 0;
27 soFromCurrent = 1;
28 soFromEnd = 2;
29
30Type
31 EStreamError=Class(Exception);
32 EFCreateError=Class(EStreamError);
33 EFOpenError=Class(EStreamError);
34
35 TStream=Class(TObject)
36 Private
37 Function GetSize:LongInt;Virtual;
38 Function GetPosition:LongInt;
39 Procedure SetPosition(NewPos:LongInt);
40 Procedure Error(ResourceId:Word);Virtual;
41 Public
42 Procedure ReadBuffer(Var Buffer;Count:LongInt);
43 Procedure WriteBuffer(Const Buffer;Count:LongInt);
44 Function CopyFrom(Source: TStream; Count: LongInt): LongInt;
45 Function Read(Var Buffer;Count:LongInt):LongInt;Virtual;Abstract;
46 Function Write(Const Buffer;Count:LongInt):LongInt;Virtual;Abstract;
47 Function Seek(Offset:LongInt;Origin:Word):LongInt;Virtual;Abstract;
48 Function EndOfData: Boolean; Virtual;
49 Function ReadLn: String; Virtual;
50 Procedure WriteLn(Const S: String); Virtual;
51 Public
52 Property Position:LongInt Read GetPosition Write SetPosition;
53 Property Size:LongInt Read GetSize;
54 End;
55
56
57Const
58 {FileStream Open modes}
59 fmCreate = $FFFF; (* Delphi *)
60
61 Stream_Create = fmCreate; (* compatibility only *)
62 Stream_Open = fmInOut; (* compatibility only *)
63 Stream_OpenRead = fmOpenRead Or fmShareDenyWrite;
64
65Type
66 THandleStream= Class(TStream)
67 Private
68 FHandle: LongInt;
69 Public
70 Constructor Create(AHandle: LongInt);
71 Function Read(Var Buffer; Count: LongInt): LongInt; Override;
72 Function Write(Const Buffer; Count: LongInt): LongInt; Override;
73 Function Seek(Offset: LongInt; Origin: Word): LongInt; Override;
74 Public
75 Property Handle: LongInt Read FHandle;
76 End;
77
78Type
79 TFileStream=Class(TStream)
80 Private
81 PStreamFile:File;
82 Public
83 Constructor Create(Const FileName:String;Mode:LongWord);
84 Destructor Destroy;Override;
85 Function Read(Var Buffer;Count:LongInt):LongInt;Override;
86 Function Write(Const Buffer;Count:LongInt):LongInt;Override;
87 Function Seek(Offset:LongInt;Origin:Word):LongInt;Override;
88 End;
89
90
91 TMemoryStream=Class(TStream)
92 Private
93 FBuffer: PByteArray;
94 FSize, FCapacity, FPosition: LongInt;
95 Procedure SetCapacity(NewCapacity: LongInt);
96 Protected
97 Property Capacity:LongInt Read FCapacity Write SetCapacity;
98 Public
99 Destructor Destroy;Override;
100 Function Read(Var Buffer;Count:LongInt):LongInt;Override;
101 Function Write(Const Buffer; Count: LongInt):LongInt;Override;
102 Function Seek(Offset: LongInt; Origin: Word):LongInt;Override;
103 Procedure LoadFromStream(Stream: TStream);
104 Procedure LoadFromFile(Const FileName:String);
105 Procedure SaveToStream(Stream: TStream);
106 Procedure SaveToFile(Const FileName:String);
107 Procedure SetSize(NewSize: LongInt);
108 Procedure Clear;
109 Public
110 Property Memory: PByteArray Read FBuffer;
111 End;
112
113
114Const
115 MaxListSize = MaxLongInt Div SizeOf(Pointer);
116
117 { A notify event Is A method variable, I.E. A Procedure
118 variable For Objects. Some Classes allow the specification
119 Of Objects To be notified Of changes. }
120
121
122Type
123 TComponent=Class;
124
125{$M+}
126 TNotifyEvent = Procedure(Sender:TObject) Of Object;
127{$M-}
128
129 EListError = Class(Exception);
130
131 {TList Class}
132 TList = Class;
133 PPointerList = ^TPointerList;
134 TPointerList = Array[0..MaxListSize-1] Of Pointer;
135 TListSortCompare = Function(Item1,Item2: Pointer):LongInt;
136
137 TFreeListItem = Procedure(Sender:TObject;Item:Pointer) Of Object;
138
139 TList = Class
140 Private
141 FList:PPointerList;
142 FCount:LongInt;
143 FCapacity:LongInt;
144 FGrowth:LongInt;
145 FOnFreeItem:TFreeListItem;
146 Function Get(Index:LongInt):Pointer;
147 Procedure Put(Index:LongInt;Item:Pointer);
148 Procedure SetCount(NewCount:LongInt);
149 Protected
150 Procedure Error; Virtual;
151 Procedure Grow; Virtual;
152 Procedure SetCapacity(NewCapacity:LongInt); Virtual;
153 Procedure FreeItem(Item:Pointer); Virtual;
154 Public
155 Destructor Destroy; Override;
156 Procedure Clear; Virtual;
157 Function Add(Item:Pointer):LongInt;
158 Procedure Delete(Index:LongInt);
159 Function Remove(Item:Pointer):LongInt;
160 Procedure Cut(Index1,Index2:LongInt);
161 Procedure Insert(Index:LongInt;Item:Pointer);
162 Procedure Exchange(Index1,Index2:LongInt);
163 Procedure Move(CurIndex,NewIndex:LongInt);
164 Function IndexOf(Item:Pointer):LongInt;
165 Function First:Pointer;
166 Function Last:Pointer;
167 Function Expand:TList;
168 Procedure Pack;
169 Procedure Sort(Compare: TListSortCompare);
170 Procedure AddList(List:TList);
171 Procedure Assign(List:TList);
172 Public
173 Property Capacity:LongInt Read FCapacity Write SetCapacity;
174 Property Count:LongInt Read FCount Write SetCount;
175 Property Growth:LongInt Read FGrowth Write FGrowth;
176 Property Items[Index:LongInt]:Pointer Read Get Write Put; Default;
177 Property List:PPointerList Read FList;
178 Property OnFreeItem:TFreeListItem Read FOnFreeItem Write FOnFreeItem;
179 End;
180
181
182 {TChainList Class}
183 PChainListItem = ^TChainListItem;
184 TChainListItem = Record
185 Prev:PChainListItem;
186 Item:Pointer;
187 Next:PChainListItem;
188 End;
189
190
191 TChainList = Class(TObject)
192 Private
193 FList:PChainListItem;
194 FListEnd:PChainListItem;
195 FCount:LongInt;
196 FOnFreeItem:TFreeListItem;
197 Private
198 Function Index2PLE(Index:LongInt):PChainListItem;
199 Function Item2PLE(Item:Pointer):PChainListItem;
200 Function PLE2Index(ple:PChainListItem):LongInt;
201 Function Item2Index(Item:Pointer):LongInt;
202 Procedure Connect(ple1,ple2:PChainListItem);
203 Function Get(Index:LongInt):Pointer;
204 Procedure Put(Index:LongInt;Item:Pointer);
205 Protected
206 Procedure Error; Virtual;
207 Procedure FreeItem(Item:Pointer); Virtual;
208 Public
209 Destructor Destroy; Override;
210 Procedure Clear; Virtual;
211 Function Add(Item:Pointer):LongInt;
212 Function Remove(Item:Pointer):LongInt;
213 Procedure Delete(Index:LongInt);
214 Function First:Pointer;
215 Function Last:Pointer;
216 Function IndexOf(Item:Pointer):LongInt;
217 Procedure Insert(Index:LongInt;Item:Pointer);
218 Procedure Move(CurIndex,NewIndex:LongInt);
219 Procedure Exchange(Index1,Index2:LongInt);
220 Procedure Pack;
221 Public
222 Property Count:LongInt Read FCount;
223 Property Items[Index:LongInt]:Pointer Read Get Write Put; Default;
224 Property OnFreeItem:TFreeListItem Read FOnFreeItem Write FOnFreeItem;
225 End;
226
227 { TStrings Is an Abstract base Class For storing a
228 Number Of Strings. Every String can be associated
229 With A Value As well As With an Object. So, If you
230 want To Store simple Strings, Or collections Of
231 keys And values, Or collection Of named Objects,
232 TStrings Is the Abstract ancestor you should
233 derive your Class from. }
234
235Type
236 EStringListError = Class(Exception);
237
238 TStrings = Class(TObject)
239 Private
240 FUpdateSemaphore: LongInt;
241 FPreventFree: Boolean;
242 Function GetValue(Const Name: String): String;
243 Procedure SetValue(Const Name, Value: String);
244 Function FindValue(Const Name: String; Var Value: String): LongInt;
245 Function GetName(Index: LongInt): String;
246 Protected
247 Function Get(Index: LongInt): String; Virtual; Abstract;
248 Function GetCount: LongInt; Virtual; Abstract;
249 Function GetObject(Index: LongInt): TObject; Virtual;
250 Procedure Put(Index: LongInt; Const S: String); Virtual;
251 Procedure PutObject(Index: LongInt; AObject: TObject); Virtual;
252 Procedure SetUpdateState(Updating: Boolean); Virtual;
253 Function GetTextStr: AnsiString; Virtual;
254 Procedure SetTextStr(Const Value: AnsiString); Virtual;
255 Public
256 Function Add(Const S: String): LongInt; Virtual;
257 Function AddObject(Const S: String; AObject: TObject): LongInt; Virtual;
258 Procedure AddStrings(AStrings: TStrings); Virtual;
259 Procedure Append(Const S: String);
260 Procedure Assign(AStrings: TStrings); Virtual;
261 Procedure BeginUpdate;
262 Procedure Clear; Virtual; Abstract;
263 Procedure Delete(Index: LongInt); Virtual; Abstract;
264 Procedure EndUpdate;
265 Function Equals(AStrings: TStrings): Boolean;
266 Procedure Exchange(Index1, Index2: LongInt); Virtual;
267 Function GetText: PChar;Virtual;
268 Function IndexOf(Const S: String): LongInt; Virtual;
269 Function IndexOfName(Const Name: String): LongInt;
270 Function IndexOfObject(AObject: TObject): LongInt;
271 Procedure Insert(Index: LongInt; Const S: String); Virtual; Abstract;
272 Procedure InsertObject(Index: LongInt; Const S: String; AObject: TObject); Virtual;
273 Procedure LoadFromFile(Const FileName: String);
274 Procedure SetText(Text: PChar);Virtual;
275 Procedure LoadFromStream(Stream: TStream); Virtual;
276 Procedure Move(CurIndex, NewIndex: LongInt); Virtual;
277 Procedure SaveToFile(Const FileName: String);
278 Procedure SaveToStream(Stream: TStream); Virtual;
279 Public
280 Property Names[Index: LongInt]: String Read GetName;
281 Property Count: LongInt Read GetCount;
282 Property Objects[Index: LongInt]: TObject Read GetObject Write PutObject;
283 Property values[Const Name: String]: String Read GetValue Write SetValue;
284 Property Strings[Index: LongInt]: String Read Get Write Put; Default;
285 Property Text:AnsiString Read GetTextStr Write SetTextStr;
286 End;
287
288{ TStringList Is A concrete Class derived
289 from TStrings. TStringList stores its Items
290 In A Private field Of Type TList. It's very
291 fast, since it performs binary Search For
292 retrieving Objects by Name. you can specify
293 whether you want TStringList To be sorted Or
294 unsorted As well As Case-sensitive Or Not.
295 you can also specify the way A TStringList
296 Object handles duplicate entries.
297
298 TStringList Is able To notify the user when
299 the list's Data changes Or has been changed.
300 Use the properties OnChange And OnChanged. }
301
302Type
303 TDuplicates = (dupIgnore, dupAccept, dupError);
304
305 TFreeStringListItem = Procedure(Sender:TObject;AObject:TObject) Of Object;
306
307Type
308 TStringList = Class(TStrings)
309 Private
310 FList: TList;
311 FSorted: Boolean;
312 FDuplicates: TDuplicates;
313 FCaseSensitive: Boolean;
314 FOnChange: TNotifyEvent;
315 FOnChanging: TNotifyEvent;
316 FOnFreeItem: TFreeStringListItem;
317 FLockChange:Boolean;
318 Procedure BottomUpHeapSort;
319 Procedure SetSorted(Value: Boolean);
320 Procedure SetCaseSensitive(Value: Boolean);
321 Protected
322 Procedure changed; Virtual;
323 Procedure Changing; Virtual;
324 Function Get(Index: LongInt): String; Override;
325 Function GetCount: LongInt; Override;
326 Function GetObject(Index: LongInt): TObject; Override;
327 Procedure Put(Index: LongInt; Const S: String); Override;
328 Procedure PutObject(Index: LongInt; AObject: TObject); Override;
329 Procedure SetUpdateState(Updating: Boolean); Override;
330 Procedure FreeItem(AObject: TObject);Virtual;
331 Function GetValuePtr(Index:Longint): PString;
332 Public
333 Constructor Create;
334 Destructor Destroy; Override;
335 Function Add(Const S: String): LongInt; Override;
336 Procedure Clear; Override;
337 Procedure Delete(Index: LongInt); Override;
338 Procedure Exchange(Index1, Index2: LongInt); Override;
339 Function Find(Const S: String; Var Index: LongInt): Boolean; Virtual;
340 Function IndexOf(Const S: String): LongInt; Override;
341 Procedure Insert(Index: LongInt; Const S: String); Override;
342 Procedure Sort; Virtual;
343 Property Duplicates: TDuplicates Read FDuplicates Write FDuplicates;
344 Property CaseSensitive: Boolean Read FCaseSensitive Write SetCaseSensitive;
345 Property sorted: Boolean Read FSorted Write SetSorted;
346 Property OnChange: TNotifyEvent Read FOnChange Write FOnChange;
347 Property OnChanging: TNotifyEvent Read FOnChanging Write FOnChanging;
348 Property OnFreeItem: TFreeStringListItem Read FOnFreeItem Write FOnFreeItem;
349 Property ValuePtrs[Index:Longint]: PString Read GetValuePtr;
350 End;
351
352{ StrItem Is A space-efficient way To Store an Object
353 associated With A String. it Is used inside TStringList. }
354
355Type
356 PStrItem = ^TStrItem;
357 TStrItem = Record
358 FObject: TObject;
359 FString: String;
360 End;
361
362Function NewStrItem(Const AString: String; AObject: TObject): PStrItem;
363Procedure DisposeStrItem(P: PStrItem);
364
365Type
366
367{ TBits implements A Boolean Array. entries are
368 numbered 0 .. Size - 1, As usual. Bits allows
369 Read / Write access To entries. OpenBit returns
370 Index Of First True bit, Or -1 If none Is True. }
371
372 PBitsArray = ^TBitsArray;
373 TBitsArray = Array[0..MaxLongInt Div 4] Of LongWord;
374
375 EBitsError = Class(Exception);
376
377 TBits = Class
378 Private
379 FBits: PBitsArray;
380 FSize: LongInt;
381 Procedure Error;
382 Function GetBit(Index: LongInt): Boolean;
383 Procedure SetBit(Index: LongInt; bit: Boolean);
384 Procedure SetSize(NewSize: LongInt);
385 Public
386 Destructor Destroy; Override;
387 Function OpenBit: LongInt;
388 Property Bits[Index: LongInt]: Boolean Read GetBit Write SetBit; Default;
389 Property Size: LongInt Read FSize Write SetSize;
390 End;
391
392
393Type
394 //General types
395 HWindow=LongWord;
396
397 PMessage=^TMessage;
398{$M+}
399 TMessage=Record
400{$M-}
401 Msg:LongWord;
402 ReceiverClass: TObject;
403 Receiver: HWindow;
404 Handled: LongBool; {True If the Message was Handled}
405 Case Integer Of
406 0: ( Param1: LongWord;
407 Param2: LongWord;
408 Result: LongWord);
409 1: ( WParam: LongWord;
410 LParam: LongWord;
411 MsgResult: LongWord);
412 2: ( Param1Lo: Word;
413 Param1Hi: Word;
414 Param2Lo: Word;
415 Param2Hi: Word;
416 ResultLo: Word;
417 ResultHi: Word);
418 3: ( Param1LoByteLo:Byte;
419 Param1LoByteHi:Byte;
420 Param1HiByteLo:Byte;
421 Param1HiByteHi:Byte;
422 Param2LoByteLo:Byte;
423 Param2LoByteHi:Byte;
424 Param2HiByteLo:Byte;
425 Param2HiByteHi:Byte;
426 ResultLoByteLo:Byte;
427 ResultLoByteHi:Byte;
428 ResultHiByteLo:Byte;
429 ResultHiByteHi:Byte);
430 End;
431
432 HDC=LongWord;
433 HPalette=LongWord;
434
435{$M+}
436 TColor=LongInt;
437{$M-}
438
439 PPoint=^TPoint;
440{$M+}
441 TPoint=Record
442 X,Y:LongInt;
443 End;
444{$M-}
445
446 PRect=^TRect;
447{$M+}
448 TRect=Record
449 Case LongInt Of
450 0: (Left,Bottom,Right,Top:LongInt);
451 1: (LeftBottom,RightTop:TPoint);
452 End;
453{$M-}
454
455
456 PSize=^TSize;
457{$M+}
458 TSize=Record
459 CX,CY:LongInt;
460 End;
461
462 TRGB=Record
463 Blue:Byte;
464 Green:Byte;
465 Red:Byte;
466 Fill:Byte;
467 End;
468{$M-}
469
470Const
471{$M+}
472 {Default RGB color values}
473 clBlack = TColor($00000000);
474 clMaroon = TColor($00800000);
475 clGreen = TColor($00008000);
476 clOlive = TColor($00808000);
477 clNavy = TColor($00000080);
478 clPurple = TColor($00800080);
479 clTeal = TColor($00008080);
480 clGray = TColor($00808080);
481 clSilver = TColor($00C6C6C6);
482 clRed = TColor($00FF0000);
483 clLime = TColor($0000FF00);
484 clYellow = TColor($00FFFF00);
485 clBlue = TColor($000000FF);
486 clFuchsia = TColor($00FF00FF);
487 clAqua = TColor($0000FFFF);
488 clLtGray = TColor($00CCCCCC);
489 clDkGray = TColor($00808080);
490 clWhite = TColor($00FFFFFF);
491
492 {System Colors}
493 clScrollbar = TColor(0 Or $80000000);
494 clBackGround = TColor(1 Or $80000000);
495 clActiveCaption = TColor(2 Or $80000000);
496 clInactiveCaption = TColor(3 Or $80000000);
497 clMenu = TColor(4 Or $80000000);
498 clWindow = TColor(5 Or $80000000);
499 clWindowFrame = TColor(6 Or $80000000);
500 clMenuText = TColor(7 Or $80000000);
501 clWindowText = TColor(8 Or $80000000);
502 clCaptionText = TColor(9 Or $80000000);
503 clActiveBorder = TColor(10 Or $80000000);
504 clInactiveBorder = TColor(11 Or $80000000);
505 clAppWorkSpace = TColor(12 Or $80000000);
506 clHighlight = TColor(13 Or $80000000);
507 clHighlightText = TColor(14 Or $80000000);
508 clBtnFace = TColor(15 Or $80000000);
509 clBtnShadow = TColor(16 Or $80000000);
510 clGrayText = TColor(17 Or $80000000);
511 clBtnText = TColor(18 Or $80000000);
512 clInactiveCaptionText = TColor(19 Or $80000000);
513 clBtnHighlight = TColor(20 Or $80000000);
514 cl3DDkShadow = TColor(21 Or $80000000);
515 cl3DLight = TColor(22 Or $80000000);
516 clInfoText = TColor(23 Or $80000000);
517 clInfo = TColor(24 Or $80000000);
518 clBtnDefault = TColor(25 Or $80000000);
519 clDlgWindow = TColor(26 Or $80000000);
520 clEntryField = TColor(27 Or $80000000);
521 clStaticText = TColor(28 Or $80000000);
522{$M-}
523
524
525Type
526 TColorName = Record
527 Name: String[20];
528 Value: LongInt;
529 End;
530
531Const
532 MaxDefaultColors = 18;
533 DefaultColors: Array[1..MaxDefaultColors] Of TColorName = (
534 (Name:'clBlack'; Value:clBlack),
535 (Name:'clMaroon'; Value:clMaroon),
536 (Name:'clGreen'; Value:clGreen),
537 (Name:'clOlive'; Value:clOlive),
538 (Name:'clNavy'; Value:clNavy),
539 (Name:'clPurple'; Value:clPurple),
540 (Name:'clTeal'; Value:clTeal),
541 (Name:'clGray'; Value:clGray),
542 (Name:'clSilver'; Value:clSilver),
543 (Name:'clRed'; Value:clRed),
544 (Name:'clLime'; Value:clLime),
545 (Name:'clYellow'; Value:clYellow),
546 (Name:'clBlue'; Value:clBlue),
547 (Name:'clFuchsia'; Value:clFuchsia),
548 (Name:'clAqua'; Value:clAqua),
549 (Name:'clLtGray'; Value:clLtGray),
550 (Name:'clDkGray'; Value:clDkGray),
551 (Name:'clWhite'; Value:clWhite));
552
553 MaxSystemColors = 29;
554 SystemColors: Array[1..MaxSystemColors] Of TColorName = (
555 (Name:'clScrollbar'; Value:clScrollbar),
556 (Name:'clBackGround'; Value:clBackGround),
557 (Name:'clActiveCaption'; Value:clActiveCaption),
558 (Name:'clInactiveCaption'; Value:clInactiveCaption),
559 (Name:'clMenu'; Value:clMenu),
560 (Name:'clWindow'; Value:clWindow),
561 (Name:'clWindowFrame'; Value:clWindowFrame),
562 (Name:'clMenuText'; Value:clMenuText),
563 (Name:'clWindowText'; Value:clWindowText),
564 (Name:'clCaptionText'; Value:clCaptionText),
565 (Name:'clActiveBorder'; Value:clActiveBorder),
566 (Name:'clInactiveBorder'; Value:clInactiveBorder),
567 (Name:'clAppWorkSpace'; Value:clAppWorkSpace),
568 (Name:'clHighLight'; Value:clHighlight),
569 (Name:'clHighLightText'; Value:clHighlightText),
570 (Name:'clBtnFace'; Value:clBtnFace),
571 (Name:'clBtnShadow'; Value:clBtnShadow),
572 (Name:'clGrayText'; Value:clGrayText),
573 (Name:'clBtnText'; Value:clBtnText),
574 (Name:'clInactiveCaptionText'; Value:clInactiveCaptionText),
575 (Name:'clBtnHighlight'; Value:clBtnHighlight),
576 (Name:'cl3DDkShadow'; Value:cl3DDkShadow),
577 (Name:'cl3DLight'; Value:cl3DLight),
578 (Name:'clInfoText'; Value:clInfoText),
579 (Name:'clInfo'; Value:clInfo),
580 (Name:'clBtnDefault'; Value:clBtnDefault),
581 (Name:'clDlgWindow'; Value:clDlgWindow),
582 (Name:'clEntryField'; Value:clEntryField),
583 (Name:'clStaticText'; Value:clStaticText));
584
585
586Function ColorName(ColorValue:TColor):String;
587Function ColorValue(ColorName:String):TColor;
588
589
590Type
591 TResourceName=String[32];
592
593 TResourceStream=Class(TMemoryStream)
594 Private
595 FHeaderPos:LongInt;
596 FResourceList:TList;
597 SCUStream:TStream;
598 Public
599 Function NewResourceEntry(Const ResName:TResourceName;
600 Var Data;DataLen:LongInt):Boolean;
601 Function WriteResourcesToStream(Stream:TMemoryStream):Boolean;
602 Destructor Destroy;Override;
603 End;
604
605
606{Standard Resource Names For NewResourceEntry}
607Const
608 rnGlyph = 'rnGlyph';
609 rnBitmap = 'rnBitmap';
610 rnPicture = 'rnPicture';
611 rnPictureLeaf = 'rnPictureLeaf';
612 rnPictureOpen = 'rnPictureOpen';
613 rnPictureClosed = 'rnPictureClosed';
614 rnFont = 'rnFont';
615 rnTabFont = 'rnTabFont';
616 rnLines = 'rnLines';
617 rnItems = 'rnItems';
618 rnTabs = 'rnTabs';
619 rnDBServer = 'rnDBServer';
620 rnDBDataBase = 'rnDBDataBase';
621 rnDBTable = 'rnDBTable';
622 rnDBQuery = 'rnDBQuery';
623 rnDBDataField = 'rnDBDataField';
624 rnGridSizes = 'rnGridSize';
625 rnFileName = 'rnFileName';
626 rnIcon = 'rnIcon';
627 rnDBGridCols = 'rnDBGridCols';
628 rnStatusPanels = 'rnStatusPanels';
629 rnHeaders = 'rnHeaders';
630 rnBitmapList = 'rnBitmapList';
631 rnScrollExtents = 'rnScrollExtents';
632
633Type
634 TComponentState=Set Of (csDesigning,csReading,csWriting,csDestroying,
635 csLoaded,csForm,csDetail,csReferenceControl,
636 csReference,csAcceptsControls,csHandleLinks,
637 csHasMainMenu,csLoading);
638
639 TDesignerState=Set Of (dsFormVisible,dsNoRealSizing,
640 dsNoSourceCode,dsStored,dsAutoCreate);
641
642 TOperation=(opInsert,opRemove);
643
644 TGetChildProc=Procedure(Child:TComponent) Of Object;
645
646
647 ESCUError=Class(Exception);
648
649 TPersistent=Class(TObject)
650 Private
651 Procedure AssignError(Source:TPersistent);
652 Protected
653 Procedure AssignTo(Dest:TPersistent);Virtual;
654 Public
655 Procedure Assign(Source:TPersistent);Virtual;
656 End;
657
658 TPersistentClass = class of TPersistent;
659
660 TComponent=Class(TPersistent)
661 Private
662 FLanguages:Pointer;
663 FName:PString;
664 FUnitName:PString;
665 FTypeName:PString;
666 FOwner:TComponent;
667 FComponentState:TComponentState;
668 FDesignerState:TDesignerState;
669 FCreateFromSCU:Boolean;
670 FComponents:TList;
671 FFreeNotifyList:TList;
672 FMethods:Pointer;
673 FTag:LongInt;
674 FWriteComponentCount:LongInt;
675 SCUStream:TMemoryStream;
676 SCUResStream:TResourceStream;
677 SCUWriteError:Boolean;
678 FReference:TComponent;
679 Function GetComponentCount:LongInt;
680 Function GetComponent(AIndex:LongInt):TComponent;
681 Function GetComponentIndex:LongInt;
682 Procedure SetComponentIndex(Index:LongInt);
683 Function GetName:String;
684 Procedure SetName(Const NewName:String);
685 Function GetUnitName:String;
686 Function GetTypeName:String;
687 Procedure SetTypeName(NewName:String);
688 Function GetDesigned:Boolean;
689 Procedure SetupSCU;
690 Function ReadPropertiesSCU(COwner:TComponent;Namep,Resourcep:Pointer;Var ClassPointer:Pointer):Boolean;
691 Function ReadComponentsSCU(NameTable,ResourceTable:Pointer;Var ClassP:Pointer):Boolean;
692 Procedure ReadResourceSCU(ResourceTable:Pointer;Var ClassP:Pointer);
693 Procedure WriteComponent(Child:TComponent);
694 Procedure ReadSCU(Data:Pointer);
695 Protected
696 Procedure SetupComponent;Virtual;
697 Procedure Loaded;Virtual;
698 Procedure LoadedFromSCU(SCUParent:TComponent);Virtual;
699 Procedure LoadingFromSCU(SCUParent:TComponent);Virtual;
700 Procedure GetChildren(Proc:TGetChildProc);Virtual;
701 Function HasParent:Boolean;Virtual;
702 Procedure UpdateLinkList(Const PropertyName:String;LinkList:TList);Virtual; //For Component links
703 Public
704 Constructor Create(AOwner:TComponent);Virtual;
705 Destructor Destroy;Override;
706 Procedure InsertComponent(AComponent:TComponent);Virtual;
707 Procedure RemoveComponent(AComponent:TComponent);Virtual;
708 Function IndexOfComponent(AComponent:TComponent):LongInt;
709 Procedure DestroyComponents;
710 Function FindComponent(Const AName:String):TComponent;
711 Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Virtual;
712 Function WriteSCUResource(Stream:TResourceStream):Boolean;Virtual;
713 Procedure ReadFromStream(SCUStream:TStream);
714 Procedure WriteToStream(SCUStream:TStream);
715 Procedure Notification(AComponent:TComponent;Operation:TOperation);Virtual;
716 Procedure FreeNotification(AComponent:TComponent);Virtual;
717 Procedure SetDesigning(Value:Boolean);Virtual;
718 Procedure GetDesignerPopupEvents(AString:TStringList);Virtual;
719 Procedure DesignerPopupEvent(Id:LongInt);Virtual;
720 Property Owner:TComponent Read FOwner write FOwner;
721 Property Components[Index:LongInt]:TComponent Read GetComponent;
722 Property ComponentCount:LongInt Read GetComponentCount;
723 Property ComponentIndex:LongInt Read GetComponentIndex Write SetComponentIndex;
724 Property ComponentState:TComponentState Read FComponentState Write FComponentState;
725 Property DesignerState:TDesignerState Read FDesignerState Write FDesignerState; stored;
726 Property UnitName:String Read GetUnitName;
727 Property TypeName:String Read GetTypeName Write SetTypeName;
728 Property Designed:Boolean Read GetDesigned;
729 Property FreeNotifyList:TList Read FFreeNotifyList;
730 Property Methods:Pointer Read FMethods Write FMethods; {undocumented}
731 Published
732 Property Name:String Read GetName Write SetName;
733 Property Tag:LongInt Read FTag Write FTag;
734 End;
735 TComponentClass=Class Of TComponent;
736
737 TCollection = Class;
738
739 TCollectionItem = Class
740 Private
741 FCollection:TCollection;
742 Private
743 Function GetIndex:LongInt;
744 Procedure SetCollection(NewValue:TCollection);
745 Protected
746 Procedure SetIndex(NewIndex:LongInt);Virtual;
747 Procedure changed(AllItems:Boolean);
748 Public
749 Procedure Assign(Source:TCollectionItem);Virtual;Abstract;
750 Constructor Create(ACollection: TCollection);Virtual;
751 Destructor Destroy;Override;
752 Public
753 Property collection:TCollection Read FCollection Write SetCollection;
754 Property Index:LongInt Read GetIndex Write SetIndex;
755 End;
756
757 TCollectionItemClass=Class Of TCollectionItem;
758
759 TCollection=Class(TComponent)
760 Private
761 FItemClass:TCollectionItemClass;
762 FItems:TList;
763 FUpdateCount:LongInt;
764 Private
765 Function GetCount:LongInt;
766 Procedure InsertItem(Item:TCollectionItem);
767 Procedure RemoveItem(Item:TCollectionItem);
768 Protected
769 Procedure changed;
770 Function GetItem(Index:LongInt):TCollectionItem;
771 Procedure SetItem(Index:LongInt;Value:TCollectionItem);
772 Public
773 Procedure Update(Item:TCollectionItem);Virtual;
774 Procedure SetupComponent;Override;
775 Destructor Destroy;Override;
776 Function Add:TCollectionItem;
777 Procedure Assign(Source:TCollection);Virtual;
778 Procedure BeginUpdate;
779 Procedure Clear;
780 Procedure EndUpdate;
781 Function Insert(Index:longint):TCollectionItem;
782 Procedure Swap(Index1,Index2:longint);
783 Public
784 Property Count:LongInt Read GetCount;
785 Property Items[Index:LongInt]:TCollectionItem Read GetItem Write SetItem;
786 Property ItemClass:TCollectionItemClass Read FItemClass Write FItemClass;
787 End;
788
789
790 TStringSelectList=Class(TComponent)
791 Private
792 FList:TStringList;
793 FSelected:String;
794 Protected
795 Procedure SetStringItem(NewValue:String);Virtual;
796 Procedure SetupComponent;Override;
797 Public
798 Destructor Destroy;Override;
799 Function GetItems:TStringList;Virtual;
800 Property SelectedItem:String Read FSelected Write SetStringItem;
801 Property Items:TStringList Read GetItems;
802 End;
803
804
805 {$M+}
806 TThreadPriority=(tpIdle,tpLowest,tpLower,tpNormal,tpHigher,tpHighest,tpTimeCritical);
807 {$M-}
808
809 TThreadMethod=Procedure Of Object;
810
811 TThread=Class
812 Private
813 FOnTerminate:TNotifyEvent;
814 FHandle:LongWord;
815 FPriority:TThreadPriority;
816 FFreeOnTerminate:Boolean;
817 FTerminated:Boolean;
818 FReturnValue:LongInt;
819 FSuspended:Boolean;
820 FFinished:Boolean;
821 FThreadId:LongWord;
822 FParameter:Pointer;
823 FMethod:TThreadMethod;
824 Procedure SetSuspended(NewValue:Boolean);
825 Procedure SetPriority(NewValue:TThreadPriority);
826 Procedure SyncTerminate;
827 Procedure MsgIdle;
828 Protected
829 Procedure DoTerminate;Virtual;
830 Procedure Execute;Virtual;Abstract;
831 Public
832 Constructor Create(CreateSuspended:Boolean);
833 Constructor ExtCreate(CreateSuspended:Boolean;StackSize:LongWord;
834 Priority:TThreadPriority;Param:Pointer);
835 Destructor Destroy;Override;
836 Function WaitFor:LongInt;
837 Procedure Terminate;
838 Procedure Suspend;
839 Procedure Resume;
840 Procedure Kill;
841 Procedure Synchronize(method:TThreadMethod);
842 Procedure ProcessMsgs;
843 Property Terminated:Boolean Read FTerminated;
844 Property ReturnValue:LongInt Read FReturnValue Write FReturnValue;
845 Property ThreadId:LongWord Read FThreadId;
846 Property Handle:LongWord Read FHandle;
847 Property Priority:TThreadPriority Read FPriority Write SetPriority;
848 Property Parameter:Pointer Read FParameter Write FParameter;
849 Property Suspended:Boolean Read FSuspended Write SetSuspended;
850 Property FreeOnTerminate:Boolean Read FFreeOnTerminate Write FFreeOnTerminate;
851 Property OnTerminate:TNotifyEvent Read FOnTerminate Write FOnTerminate;
852 End;
853
854
855Procedure RegisterClasses(Const ComponentClasses: Array Of TComponentClass);
856Function SearchClassByName(Const Name:String):TComponentClass;
857Function CallReadProp(Objekt:TObject;FuncAddr:Pointer;Typ:Byte;
858 TypLen:LongInt;Value:Pointer):Boolean;
859Function CallWriteProp(Objekt:TObject;ProcAddr:Pointer;Typ:Byte;
860 TypLen:LongInt;Value:Pointer):Boolean;
861
862
863Type
864 PSCUFileFormat=^TSCUFileFormat;
865 TSCUFileFormat=Record
866 Version:String[5];
867 ObjectOffset,ObjectLen:LongInt;
868 NameTableOffset,NameTableLen:LongInt;
869 ResourceOffset,ResourceLen:LongInt;
870 ObjectCount:LongInt;
871 UseEntry:LongInt; {used by project management}
872 NextEntry:Pointer;
873 {auch System „ndern (AddSCUData) und Compiler.PAS}
874 End;
875
876
877 PFormListItem=^TFormListItem;
878 TFormListItem=Record
879 Form:TComponent;
880 FormName:String[64];
881 UnitName:String;
882 AutoCreate:Boolean;
883 SCUPointer:Pointer;
884 SCUSize:LongInt;
885 End;
886
887
888Function WritePropertiesToStream(FormList:TList):TMemoryStream;
889Function WritePropertiesToFile(FileName:String;FormList:TList):Boolean;
890
891
892Type
893 TMsgDlgBtn=(mbYes,mbNo,mbOk,mbCancel,mbAbort,mbRetry,mbIgnore,mbAll,mbHelp);
894 TMsgDlgButtons=Set Of TMsgDlgBtn;
895 TMsgDlgType=(mtWarning,mtError,mtInformation,mtConfirmation,mtCustom,mtCritical);
896 TMsgDlgReturn=LongWord;
897Const
898 mrBase = $8000; //cmBase
899 mrOk = mrBase+50; //cmOk
900 mrCancel = mrBase+51; //cmCancel
901 mrYes = mrBase+53; //cmYes
902 mrNo = mrBase+54; //cmNo
903 mrIgnore = mrBase+58; //cmIgnore
904 mrRetry = mrBase+57; //cmRetry
905 mrAbort = mrBase+56; //cmAbort
906 mrNone = 0; //cmNull
907 mrAll = mrBase+59; //cmAll
908
909Const
910 mbYesNo=[mbYes,mbNo];
911 mbYesNoCancel=[mbYes,mbNo,mbCancel];
912 mbOkCancel=[mbOk,mbCancel];
913 mbAbortRetryIgnore=[mbAbort,mbRetry,mbIgnore];
914
915
916Function MessageBox2(Const Msg:String;Typ:TMsgDlgType;Buttons:TMsgDlgButtons):TMsgDlgReturn;
917Function ErrorBox2(Const Msg:String):TMsgDlgReturn;
918
919Function GetExperts:TList; {noch raus?}
920
921
922Var RegisteredClasses:TList;
923 PropertyEditDialogs:TList;
924 LibExperts:TList;
925 LibExpertInstances:TList;
926
927Type
928 TPropertyEditorReturn=(edOk,edCancel,edList,edNoEditor);
929
930 TPropertyEditor=Class(TComponent)
931 Private
932 FPropertyOwner:TComponent;
933 FPropertyName:String;
934 FList:TStringList;
935 Public
936 Function Execute(Var Value;ValueLen:LongInt):TPropertyEditorReturn;Virtual;Abstract;
937 Public
938 Property PropertyOwner:TComponent Read FPropertyOwner;
939 Property PropertyName:String Read FPropertyName;
940 Property List:TStringList Read FList;
941 End;
942 TPropertyEditorClass=Class Of TPropertyEditor;
943
944 {$HINTS OFF}
945 TStringPropertyEditor=Class(TPropertyEditor)
946 Public
947 Function Execute(Var Value:String;ValueLen:LongInt):TPropertyEditorReturn;Virtual;Abstract;
948 End;
949
950 TShortIntPropertyEditor=Class(TPropertyEditor)
951 Public
952 Function Execute(Var Value:ShortInt):TPropertyEditorReturn;Virtual;Abstract;
953 End;
954
955 TIntegerPropertyEditor=Class(TPropertyEditor)
956 Public
957 Function Execute(Var Value:Integer):TPropertyEditorReturn;Virtual;Abstract;
958 End;
959
960 TLongIntPropertyEditor=Class(TPropertyEditor)
961 Public
962 Function Execute(Var Value:LongInt):TPropertyEditorReturn;Virtual;Abstract;
963 End;
964
965 TClassPropertyEditorReturn=(peOk,peCancel,peClear,peNoEditor);
966
967 TClassPropertyEditor=Class(TPropertyEditor)
968 Private
969 Property PropertyOwner;
970 Property PropertyName;
971 Property List;
972 Public
973 Function Execute(Var ClassToEdit:TObject):TClassPropertyEditorReturn;Virtual;
974 End;
975 TClassPropertyEditorClass=Class Of TClassPropertyEditor;
976 {$HINTS ON}
977
978 EClassNotFound=Class(Exception);
979
980Procedure RegisterClass(Const ComponentClass:TComponentClass);
981Function GetClass(Const ClassName:String):TComponentClass;
982Function FindClass(Const ClassName:String):TComponentClass;
983Procedure UnRegisterClass(AClass:TComponentClass);
984Procedure UnRegisterClasses(Const AClasses:Array of TComponentClass);
985Procedure AddPropertyEditor(OwnerClass:TClass;PropertyName:String;PropertyEditor:TPropertyEditorClass);
986Function CallPropertyEditor(Owner:TComponent;PropertyName:String;Var Value;ValueLen:LongInt;
987 Var List:TStringList):TPropertyEditorReturn;
988Function PropertyEditorAvailable(OwnerClass:TClass;PropertyName:String):Boolean;
989
990Procedure AddClassPropertyEditor(ClassToEdit:TClass;PropertyEditor:TClassPropertyEditorClass);
991Function CallClassPropertyEditor(Var ClassToEdit:TObject):TClassPropertyEditorReturn;
992Function ClassPropertyEditorAvailable(ClassName:String):Boolean;
993
994Procedure AddDesignerPopupEvent(AString:TStringList;Caption:String;Id:LongInt);
995
996Function GetTempFileName:String;
997Function InDesigner:Boolean;
998
999
1000Implementation
1001
1002//!!!!!!!!!! bei Žnderungen auch Language Manager und SIB_DLG „ndern!!!!!!!!!!!!!!!!!!!
1003Type
1004 PLanguageMessages=^TLanguageMessages;
1005 TLanguageMessages=Record
1006 Name:PString; //Language Name
1007 StringTableLen:LongWord;
1008 StringTable:Pointer;
1009 Next:PLanguageMessages;
1010 End;
1011
1012 PLanguageComponent=^TLanguageComponent;
1013 TLanguageComponent=Record
1014 Name:PString;
1015 OriginalInstance:TComponent;
1016 Instance:TComponent;
1017 ValueScope:Byte;
1018 ValueTyp:Byte;
1019 ValueRead:TPropertyReadWriteRecord;
1020 ValueWrite:TPropertyReadWriteRecord;
1021 ValueSize:LongWord;
1022 ValueLen:LongWord;
1023 Value:Pointer;
1024 ControlLeft,ControlBottom:LongInt;
1025 ControlWidth,ControlHeight:LongInt;
1026 OrigControlLeft,OrigControlBottom:LongInt;
1027 OrigControlWidth,OrigControlHeight:LongInt;
1028 Next:PLanguageComponent;
1029 End;
1030
1031 PLanguageItem=^TLanguageItem;
1032 TLanguageItem=Record
1033 Name:PString;
1034 Components:PLanguageComponent;
1035 Menus:PLanguageComponent;
1036 StringTables:PLanguageComponent;
1037 Next:PLanguageItem;
1038 End;
1039//!!!!!!!!!! bei Žnderungen auch Language Manager „ndern!!!!!!!!!!!!!!!!!!!
1040 PLanguageInfo=^TLanguageInfo;
1041 TLanguageInfo=Record
1042 CurrentLanguageName:PString; //only Copy !!
1043 CurrentLanguageComponents:PLanguageComponent; //only Copy !
1044 CurrentLanguageMenus:PLanguageComponent; //only Copy !
1045 CurrentLanguageStringTables:PLanguageComponent; //only Copy
1046 Items:PLanguageItem;
1047 End;
1048//!!!!!!!!!! bei Žnderungen auch Language Manager und SIB_DLG „ndern!!!!!!!!!!!!!!!!!!!
1049//////////////////////////////////////////////////////////////////////////////////////////////////////////
1050
1051Var LanguageMessages:PLanguageMessages;
1052 AppLanguage:String;
1053
1054Procedure DestroyMessages;
1055Var dummy:PLanguageMessages;
1056Begin
1057 While LanguageMessages<>NIL Do
1058 Begin
1059 dummy:=LanguageMessages^.Next;
1060 If LanguageMessages^.Name<>Nil Then
1061 FreeMem(LanguageMessages^.Name,length(LanguageMessages^.Name^)+1);
1062 If LanguageMessages^.StringTable<>Nil Then
1063 FreeMem(LanguageMessages^.StringTable,LanguageMessages^.StringTableLen);
1064 Dispose(LanguageMessages);
1065 LanguageMessages:=dummy;
1066 End;
1067 LanguageMessages:=Nil;
1068 AppLanguage:='Default';
1069End;
1070
1071Type TLanguageComponentKinds=(Captions,Menus,StringTables);
1072
1073
1074Procedure SetupLanguageComponents(Component:TComponent;Items:PLanguageComponent;Kind:TLanguageComponentKinds);
1075Var
1076 WriteTyp,ReadTyp:Byte;
1077 WriteOffset,ReadOffset:LongWord;
1078 ValueTyp:Byte;
1079 Info:TPropertyTypeInfo;
1080 S,s1:String;
1081 T:LongInt;
1082 Temp,Temp1:TComponent;
1083 p2:^LongWord;
1084 B:Byte;
1085 C:TObject;
1086
1087 Procedure WriteInt(Const Name:String;Value:LongInt);
1088 Var Info:TPropertyTypeInfo;
1089 Begin
1090 If Temp.GetPropertyTypeInfo(Name,Info) Then
1091 Begin
1092 //Info available
1093 Case Info.Write.Kind Of
1094 1:
1095 Begin
1096 p2:=Pointer(Temp);
1097 Inc(p2,Info.Write.VarOffset);
1098 System.Move(Value,p2^,Info.Size);
1099 End;
1100 2,3:
1101 Begin
1102 CallWriteProp(Temp,Pointer(Info.Write.VarOffset),
1103 Info.Typ,Info.Size,@Value);
1104 End;
1105 End; //Case
1106 End;
1107 End;
1108
1109Label skip;
1110Begin
1111 While Items<>Nil Do //process All Language Components
1112 Begin
1113 If ((Items^.ValueTyp<>0)And(Items^.ValueWrite.Kind<>0)And(Items^.Instance<>Nil)) Then //Read And Write information are Valid
1114 Begin
1115 ValueTyp:=Items^.ValueTyp;
1116 WriteTyp:=Items^.ValueWrite.Kind;
1117 WriteOffset:=Items^.ValueWrite.VarOffset;
1118 ReadTyp:=Items^.ValueRead.Kind;
1119 ReadOffset:=Items^.ValueRead.VarOffset;
1120 Temp:=Items^.Instance;
1121 End
1122 Else
1123 Begin
1124 Temp:=Component;
1125 S:=Items^.Name^;
1126 B:=Pos('.',S);
1127 While B<>0 Do
1128 Begin
1129 s1:=Copy(S,1,B-1);
1130 Delete(S,1,B);
1131
1132 Temp1:=Nil;
1133 For T:=0 To Temp.ComponentCount-1 Do
1134 Begin
1135 Temp1:=Temp.Components[T];
1136 If Temp1.Name=s1 Then
1137 Begin
1138 Temp:=Temp1;
1139 break; //found !
1140 End;
1141 Temp1:=Nil;
1142 End;
1143 If Temp1=Nil Then Goto skip; //Not found
1144
1145 B:=Pos('.',S);
1146 End;
1147
1148 If Not Temp.GetPropertyTypeInfo(S,Info) Then Goto skip;
1149
1150 Items^.Instance:=Temp;
1151 Items^.ValueRead:=Info.Read;
1152 Items^.ValueWrite:=Info.Write;
1153 Items^.ValueSize:=Info.Size;
1154 Items^.ValueTyp:=Info.Typ;
1155 ValueTyp:=Info.Typ;
1156 WriteTyp:=Info.Write.Kind;
1157 WriteOffset:=Info.Write.VarOffset;
1158 ReadTyp:=Info.Read.Kind;
1159 ReadOffset:=Info.Read.VarOffset;
1160 End;
1161
1162 If ((ValueTyp=PropType_Class)And(Kind=StringTables)) Then
1163 Begin
1164 Case ReadTyp Of
1165 0:Goto skip;
1166 1:
1167 Begin
1168 p2:=Pointer(Temp);
1169 Inc(p2,ReadOffset);
1170 System.Move(p2^,C,4);
1171 End;
1172 2,3:
1173 Begin
1174 CallReadProp(Temp,Pointer(ReadOffset),
1175 ValueTyp,4,@C);
1176 End;
1177 Else Goto skip;
1178 End; //Case
1179
1180 If Not (C Is TStrings) Then Goto skip;
1181 TStrings(C).SetText(Pointer(Items^.Value));
1182 Goto skip;
1183 End
1184 Else If ((ValueTyp<>PropType_String)And(ValueTyp<>PropType_CString)) Then Goto skip;
1185
1186 //Info available
1187 Case WriteTyp Of
1188 1:
1189 Begin
1190 p2:=Pointer(Temp);
1191 Inc(p2,WriteOffset);
1192 System.Move(Items^.Value^,p2^,Items^.ValueLen);
1193 End;
1194 2,3:
1195 Begin
1196 CallWriteProp(Temp,Pointer(WriteOffset),
1197 ValueTyp,
1198 Items^.ValueLen,Items^.Value);
1199 End;
1200 Else Goto skip;
1201 End; //Case
1202
1203 If Kind=Captions Then
1204 If Not (csForm In Temp.ComponentState) Then
1205 Begin
1206 //Write Language specific Position
1207 WriteInt('Left',Items^.ControlLeft);
1208 WriteInt('Bottom',Items^.ControlBottom);
1209 WriteInt('Width',Items^.ControlWidth);
1210 WriteInt('Height',Items^.ControlHeight);
1211 End;
1212skip:
1213 Items:=Items^.Next;
1214 End;
1215End;
1216
1217Procedure GetLanguage(Component:TComponent;Var Language:String);
1218Var Info:PLanguageInfo;
1219Begin
1220 Info:=PLanguageInfo(Component.FLanguages);
1221 If ((Info=Nil)Or(Info^.CurrentLanguageName=Nil)) Then Language:='Default'
1222 Else Language:=Info^.CurrentLanguageName^;
1223End;
1224
1225Procedure UpdateLanguageComponents(Items:PLanguageComponent;Kind:TLanguageComponentKinds);
1226Var
1227 ReadTyp:Byte;
1228 ReadOffset:LongWord;
1229 ValueTyp:Byte;
1230 Temp:TComponent;
1231 p2:^LongWord;
1232 C:TObject;
1233 P:PChar;
1234 S:String;
1235
1236 Procedure ReadInt(Const Name:String;Var Value:LongInt);
1237 Var Info:TPropertyTypeInfo;
1238 Begin
1239 If Temp.GetPropertyTypeInfo(Name,Info) Then
1240 Begin
1241 //Info available
1242 Case Info.Read.Kind Of
1243 1:
1244 Begin
1245 p2:=Pointer(Temp);
1246 Inc(p2,Info.Read.VarOffset);
1247 System.Move(p2^,Value,Info.Size);
1248 End;
1249 2,3:
1250 Begin
1251 CallReadProp(Temp,Pointer(Info.Read.VarOffset),
1252 Info.Typ,Info.Size,@Value);
1253 End;
1254 End; //Case
1255 End;
1256 End;
1257
1258Label skip;
1259Begin
1260 While Items<>Nil Do //process All Language Components
1261 Begin
1262 If ((Items^.ValueTyp<>0)And(Items^.ValueRead.Kind>0)And(Items^.Instance<>Nil)) Then
1263 Begin
1264 ValueTyp:=Items^.ValueTyp;
1265 ReadTyp:=Items^.ValueWrite.Kind;
1266 ReadOffset:=Items^.ValueRead.VarOffset;
1267 Temp:=Items^.Instance;
1268
1269 If not (Temp Is TComponent) Then continue;
1270
1271 Try
1272 If ((ValueTyp=PropType_Class)And(Kind=StringTables)) Then
1273 Begin
1274 Case ReadTyp Of
1275 0:Goto skip;
1276 1:
1277 Begin
1278 p2:=Pointer(Temp);
1279 Inc(p2,ReadOffset);
1280 System.Move(p2^,C,4);
1281 End;
1282 2,3:
1283 Begin
1284 CallReadProp(Temp,Pointer(ReadOffset),
1285 ValueTyp,4,@C);
1286 End;
1287 Else Goto skip;
1288 End; //Case
1289
1290 If Not (C Is TStrings) Then Goto skip;
1291 P:=TStrings(C).GetText;
1292 If Items^.ValueLen>0 Then FreeMem(Items^.Value,Items^.ValueLen);
1293 If P=Nil Then
1294 Begin
1295 Items^.ValueLen:=0;
1296 Items^.Value:=Nil;
1297 End
1298 Else
1299 Begin
1300 Items^.ValueLen:=Length(P^)+1;
1301 GetMem(Items^.Value,Items^.ValueLen);
1302 Move(P^,Items^.Value^,Items^.ValueLen);
1303 StrDispose(P);
1304 End;
1305
1306 Goto skip;
1307 End
1308 Else If ValueTyp<>PropType_String Then Goto skip;
1309
1310 //Info available
1311 S:='';
1312 Case ReadTyp Of
1313 1:
1314 Begin
1315 p2:=Pointer(Temp);
1316 Inc(p2,ReadOffset);
1317 System.Move(p2^,S,Items^.ValueSize);
1318 End;
1319 2,3:
1320 Begin
1321 CallReadProp(Temp,Pointer(ReadOffset),
1322 ValueTyp,
1323 Items^.ValueSize,@S);
1324 End;
1325 Else Goto skip;
1326 End; //Case
1327
1328 If Items^.ValueLen>0 Then FreeMem(Items^.Value,Items^.ValueLen);
1329 Items^.ValueLen:=Length(S)+1;
1330 GetMem(Items^.Value,Items^.ValueLen);
1331 Move(S,Items^.Value^,Items^.ValueLen);
1332
1333 If Kind=Captions Then
1334 If Not (csForm In Temp.ComponentState) Then
1335 Begin
1336 //Write Language specific Position
1337 ReadInt('Left',Items^.ControlLeft);
1338 ReadInt('Bottom',Items^.ControlBottom);
1339 ReadInt('Width',Items^.ControlWidth);
1340 ReadInt('Height',Items^.ControlHeight);
1341 End;
1342 Except
1343 End;
1344 End;
1345skip:
1346 Items:=Items^.Next;
1347 End;
1348End;
1349
1350
1351Procedure SetLanguage(Component:TComponent;Language:String);
1352Var Info:PLanguageInfo;
1353 Item:PLanguageItem;
1354 S,s1,s2:String;
1355Begin
1356 Info:=PLanguageInfo(Component.FLanguages);
1357 If Info=Nil Then Exit;
1358 S:=Language;
1359 UpcaseStr(S);
1360 If Info^.CurrentLanguageName<>Nil Then
1361 Begin
1362 s1:=Info^.CurrentLanguageName^;
1363 UpcaseStr(s1);
1364 If S=s1 Then If S<>'DEFAULT' Then
1365 Begin
1366 Item:=Info^.Items;
1367 While Item<>Nil Do
1368 Begin
1369 s1:=Item^.Name^;
1370 UpcaseStr(s1);
1371 If S=s1 Then Exit; //the Item Is present And Set !
1372 Item:=Item^.Next;
1373 End;
1374
1375 S:='DEFAULT';
1376 End;
1377
1378 //Update old Language
1379 s1:=Info^.CurrentLanguageName^;
1380 UpcaseStr(s1);
1381 Item:=Info^.Items;
1382 While Item<>Nil Do
1383 Begin
1384 s2:=Item^.Name^;
1385 UpcaseStr(s2);
1386 If s1=s2 Then
1387 Begin
1388 UpdateLanguageComponents(Item^.Components,Captions);
1389 UpdateLanguageComponents(Item^.Menus,Menus);
1390 UpdateLanguageComponents(Item^.StringTables,StringTables);
1391 break;
1392 End;
1393 Item:=Item^.Next;
1394 End;
1395 End;
1396
1397 Item:=Info^.Items;
1398 While Item<>Nil Do
1399 Begin
1400 s1:=Item^.Name^;
1401 UpcaseStr(s1);
1402 If S=s1 Then
1403 Begin
1404 SetupLanguageComponents(Component,Item^.Components,Captions);
1405 SetupLanguageComponents(Component,Item^.Menus,Menus);
1406 SetupLanguageComponents(Component,Item^.StringTables,StringTables);
1407
1408 Info^.CurrentLanguageName:=Item^.Name;
1409 Info^.CurrentLanguageComponents:=Item^.Components;
1410 Info^.CurrentLanguageMenus:=Item^.Menus;
1411 Info^.CurrentLanguageStringTables:=Item^.StringTables;
1412
1413 Exit;
1414 End;
1415 Item:=Item^.Next;
1416 End;
1417End;
1418
1419Procedure GetAppLanguage(Var Language:String);
1420Begin
1421 Language:=AppLanguage;
1422End;
1423
1424Procedure SetAppLanguage(Const Language:String);
1425Begin
1426 AppLanguage:=Language;
1427End;
1428
1429Const
1430 {$IFDEF OS2}
1431 SCUVersion:String[5] = 'SCU01';
1432 {$ENDIF}
1433 {$IFDEF Win95}
1434 SCUVersion:String[5] = 'SCW01';
1435 {$ENDIF}
1436
1437Var
1438 InsideCompLib:Boolean;
1439 InsideWriteSCU:Boolean;
1440 InsideWriteSCUAdr:^Boolean;
1441 InsideDesigner:Boolean;
1442 InsideLanguageDesigner:Boolean;
1443
1444Type
1445 PIDE_OwnerList=^TIDE_OwnerList;
1446 TIDE_OwnerList=Record
1447 PropertyName:PString;
1448 Objekt:TComponent;
1449 End;
1450
1451 PIDE_Methods=^TIDE_Methods;
1452 TIDE_Methods=Record
1453 Name:PString;
1454 Params:PString;
1455 Owners:TList;
1456 Next:PIDE_Methods;
1457 End;
1458
1459
1460Function GetTempFileName:String;
1461Var Hour,Minute,Second,Sec100:Word;
1462 S,dir:String;
1463Begin
1464 If GetTime(Hour,Minute,Second,Sec100) = 0 Then
1465 Begin
1466 S := 'tmp'+ tostr(Minute)+tostr(Second)+tostr(Sec100) +'.tmp';
1467 End
1468 Else S := 'tmp0001.tmp';
1469
1470 dir := GetEnv('TMP');
1471 If dir = '' Then dir := GetEnv('TEMP');
1472 If dir = '' Then
1473 Begin
1474 {$I-}
1475 GetDir(0,dir);
1476 {$I+}
1477 End;
1478 If dir[Length(dir)] <> '\' Then dir := dir + '\';
1479 Result := dir + S;
1480End;
1481
1482
1483Function InDesigner:Boolean;
1484Begin
1485 Result:=InsideDesigner;
1486End;
1487
1488
1489Function ColorName(ColorValue:TColor):String;
1490Var T:LongInt;
1491Begin
1492 For T := 1 To MaxDefaultColors Do
1493 Begin
1494 If DefaultColors[T].Value = ColorValue Then
1495 Begin
1496 Result := DefaultColors[T].Name;
1497 Exit;
1498 End;
1499 End;
1500
1501 For T := 1 To MaxSystemColors Do
1502 Begin
1503 If SystemColors[T].Value = ColorValue Then
1504 Begin
1505 Result := SystemColors[T].Name;
1506 Exit;
1507 End;
1508 End;
1509
1510 Result := tostr(ColorValue);
1511End;
1512
1513
1514Function ColorValue(ColorName:String):TColor;
1515Var T:LongInt;
1516 C:Integer;
1517 S:String;
1518Begin
1519 UpcaseStr(ColorName);
1520
1521 For T := 1 To MaxDefaultColors Do
1522 Begin
1523 S := DefaultColors[T].Name;
1524 UpcaseStr(S);
1525 If S = ColorName Then
1526 Begin
1527 Result := DefaultColors[T].Value;
1528 Exit;
1529 End;
1530 End;
1531
1532 For T := 1 To MaxSystemColors Do
1533 Begin
1534 S := SystemColors[T].Name;
1535 UpcaseStr(S);
1536 If S = ColorName Then
1537 Begin
1538 Result := SystemColors[T].Value;
1539 Exit;
1540 End;
1541 End;
1542
1543 Val(ColorName,Result,C);
1544 If C <> 0 Then Result := 0;
1545End;
1546
1547
1548{
1549ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1550º º
1551º Speed-Pascal/2 Version 2.0 º
1552º º
1553º Speed-Pascal Component Classes (SPCC) º
1554º º
1555º This section: TStream Class Implementation º
1556º º
1557º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1558º º
1559ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1560}
1561
1562Function TStream.CopyFrom(Source:TStream;Count:LongInt):LongInt;
1563Var
1564 ActBufSize,T:LongInt;
1565 StreamBuffer:Pointer;
1566Const
1567 MaxBufSize = $FFFF;
1568Begin
1569 If Count = 0 Then
1570 Begin
1571 Count := Source.Size;
1572 Source.Position := 0;
1573 End;
1574
1575 Result := Count;
1576
1577 If Count > MaxBufSize Then ActBufSize:=MaxBufSize
1578 Else ActBufSize := Count;
1579
1580 GetMem(StreamBuffer,ActBufSize);
1581
1582 Try
1583 While Count<>0 Do
1584 Begin
1585 If Count>ActBufSize Then T:=ActBufSize
1586 Else T:=Count;
1587
1588 Source.ReadBuffer(StreamBuffer^,T);
1589 WriteBuffer(StreamBuffer^,T);
1590 Dec(Count,T);
1591 End;
1592 Finally
1593 FreeMem(StreamBuffer, ActBufSize);
1594 End;
1595End;
1596
1597Function TStream.GetSize:LongInt;
1598Var
1599 OldPos:LongInt;
1600 Result:LongInt;
1601Begin
1602 OldPos:=GetPosition;
1603 Result:=Seek(0,Seek_End);
1604 SetPosition(OldPos);
1605 GetSize:=Result;
1606End;
1607
1608Function TStream.EndOfData: Boolean;
1609Begin
1610 Result := (Position >= Size);
1611End;
1612
1613Function TStream.GetPosition:LongInt;
1614Begin
1615 GetPosition:=Seek(0,Seek_Current);
1616End;
1617
1618Procedure TStream.SetPosition(NewPos:LongInt);
1619Begin
1620 Seek(NewPos,Seek_Begin);
1621End;
1622
1623Procedure TStream.ReadBuffer(Var Buffer;Count:LongInt);
1624Begin
1625 If Count=0 Then Exit; {Nothing To Read}
1626 If Read(Buffer,Count)<>Count Then Error(SStreamReadErrorText);
1627End;
1628
1629Procedure TStream.WriteBuffer(Const Buffer;Count:LongInt);
1630Begin
1631 If Count=0 Then Exit;
1632 If Write(Buffer,Count)<>Count Then Error(SStreamWriteErrorText);
1633End;
1634
1635Procedure TStream.Error;
1636Begin
1637 Raise EStreamError.Create(LoadNLSStr(ResourceId));
1638End;
1639
1640Function TStream.ReadLn: String;
1641Var
1642 Buffer: cstring[260];
1643 OldPos, Count, Temp: LongInt;
1644Begin
1645 OldPos := Position;
1646
1647 Count := Read(Buffer[0], 257);
1648 Buffer[Count] := #0;
1649
1650 Temp := 0;
1651 While Not (Buffer[Temp] In [#10, #13, #26])
1652 And (Temp < Count) And (Temp < 255) Do Inc (Temp);
1653
1654 Move(Buffer[0], Result[1], Temp);
1655 Result[0]:=Chr(Temp);
1656 Inc(Temp);
1657
1658 If (Buffer[Temp - 1] = #13) And (Buffer[Temp] = #10) Then Inc(Temp);
1659
1660 Position := OldPos + Temp;
1661End;
1662
1663Procedure TStream.WriteLn(Const S: String);
1664Var
1665 CRLF: Word;
1666Begin
1667 CRLF := $0A0D;
1668 WriteBuffer(S[1], Length(S));
1669 WriteBuffer(CRLF, 2);
1670End;
1671
1672{
1673ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1674º º
1675º Speed-Pascal/2 Version 2.0 º
1676º º
1677º Speed-Pascal Component Classes (SPCC) º
1678º º
1679º This section: THandleStream Class Implementation º
1680º º
1681º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1682º º
1683ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1684}
1685
1686Constructor THandleStream.Create(AHandle: LongInt);
1687Begin
1688 FHandle := AHandle;
1689End;
1690
1691Function THandleStream.Read(Var Buffer; Count: LongInt): LongInt;
1692Begin
1693 Result := FileRead(Handle, Buffer, Count);
1694 If Result = -1 Then Result := 0;
1695End;
1696
1697Function THandleStream.Write(Const Buffer; Count: LongInt): LongInt;
1698Var Temp:^Byte;
1699Begin
1700 Temp:=@Buffer;
1701 Result := FileWrite(Handle, Temp^, Count);
1702 If Result = -1 Then Result := 0;
1703End;
1704
1705Function THandleStream.Seek(Offset: LongInt; Origin: Word): LongInt;
1706Begin
1707 Result := FileSeek(Handle, Offset, Origin);
1708 If Result < 0 Then Error(SStreamSeekErrorText);
1709End;
1710
1711{
1712ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1713º º
1714º Speed-Pascal/2 Version 2.0 º
1715º º
1716º Speed-Pascal Component Classes (SPCC) º
1717º º
1718º This section: TFileStream Class Implementation º
1719º º
1720º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1721º º
1722ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1723}
1724
1725Constructor TFileStream.Create(Const FileName:String;Mode:LongWord);
1726Var
1727 SaveMode: LongWord;
1728Begin
1729 Inherited Create;
1730
1731 SaveMode := FileMode;
1732
1733 If Mode = fmCreate Then FileMode := fmOpenReadWrite Or fmShareExclusive
1734 Else FileMode := Mode;
1735
1736 Try
1737 Assign(PStreamFile,FileName);
1738 If Mode = fmCreate Then
1739 Begin
1740 {$I-}
1741 Rewrite(PStreamFile,1);
1742 {$I+}
1743 If InOutRes<>0 Then Raise EFCreateError.Create(LoadNLSStr(SStreamCreateErrorText));
1744 End
1745 Else
1746 Begin
1747 {$I-}
1748 Reset(PStreamFile,1);
1749 {$I+}
1750 If InOutRes<>0 Then Raise EFOpenError.Create(LoadNLSStr(SStreamOpenErrorText));
1751 End;
1752 Finally
1753 FileMode := SaveMode;
1754 End;
1755End;
1756
1757Destructor TFileStream.Destroy;
1758Begin
1759 {$I-}
1760 Close(PStreamFile);
1761 {$I+}
1762 Inherited Destroy;
1763End;
1764
1765Function TFileStream.Read(Var Buffer;Count:LongInt):LongInt;
1766Var
1767 Result:LongWord;
1768Begin
1769 {$I-}
1770 BlockRead(PStreamFile,Buffer,Count,Result);
1771 {$I+}
1772 If InOutRes<>0 Then Error(SStreamReadErrorText);
1773 Read:=Result;
1774End;
1775
1776Function TFileStream.Write(Const Buffer;Count:LongInt):LongInt;
1777Var
1778 pb:Pointer;
1779 Result:LongWord;
1780Begin
1781 pb:=@Buffer;
1782 {$I-}
1783 BlockWrite(PStreamFile,pb^,Count,Result);
1784 {$I+}
1785 If InOutRes<>0 Then Error(SStreamWriteErrorText);
1786 Write:=Result;
1787End;
1788
1789Function TFileStream.Seek(Offset:LongInt;Origin:Word):LongInt;
1790Var
1791 SaveSeekMode:LongWord;
1792Begin
1793 SaveSeekMode:=SeekMode;
1794 SeekMode:=Origin;
1795 {$I-}
1796 System.Seek(PStreamFile,Offset);
1797 {$I+}
1798 If InOutRes<>0 Then Error(SStreamSeekErrorText);
1799 SeekMode:=SaveSeekMode;
1800 {$I-}
1801 Seek:=FilePos(PStreamFile);
1802 {$I+}
1803 If InOutRes<>0 Then Error(SStreamSeekErrorText);
1804End;
1805
1806{
1807ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1808º º
1809º Speed-Pascal/2 Version 2.0 º
1810º º
1811º Speed-Pascal Component Classes (SPCC) º
1812º º
1813º This section: TMemoryStream Class Implementation º
1814º º
1815º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1816º º
1817ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1818}
1819
1820Const
1821 MemoryDelta = 8192;
1822
1823Destructor TMemoryStream.Destroy;
1824Begin
1825 Clear;
1826 Inherited Destroy;
1827End;
1828
1829Function TMemoryStream.Read(Var Buffer; Count: LongInt): LongInt;
1830Begin
1831 If Count > 0 Then
1832 Begin
1833 Result := FSize - FPosition;
1834 If Count < Result Then Result := Count;
1835 Move(FBuffer^[FPosition], Buffer, Result);
1836 Inc(FPosition, Result);
1837 End
1838 Else Result := 0;
1839End;
1840
1841Function TMemoryStream.Write(Const Buffer; Count: LongInt): LongInt;
1842Var
1843 NewPos, Needed: LongInt;
1844Begin
1845 If Count > 0 Then
1846 Begin
1847 NewPos := FPosition + Count;
1848 If NewPos > FSize Then
1849 Begin
1850 FSize := NewPos;
1851 If NewPos > FCapacity Then
1852 Begin
1853 Needed := (NewPos - FCapacity + MemoryDelta - 1) Div MemoryDelta;
1854 SetCapacity(FCapacity + Needed * MemoryDelta);
1855 End;
1856 End;
1857 Move(Buffer, FBuffer^[FPosition], Count);
1858 FPosition := NewPos;
1859 End;
1860 Result := Count;
1861End;
1862
1863Function TMemoryStream.Seek(Offset: LongInt; Origin: Word): LongInt;
1864Begin
1865 Case Origin Of
1866 soFromBeginning: Result := Offset;
1867 soFromCurrent: Result := FPosition + Offset;
1868 soFromEnd: Result := FSize - Offset;
1869 End;
1870 If (Result < 0) Or (Result > FSize) Then Error(SStreamSeekErrorText)
1871 Else FPosition := Result;
1872End;
1873
1874Procedure TMemoryStream.LoadFromStream(Stream: TStream);
1875Var
1876 ToDo: LongInt;
1877Begin
1878 Stream.Position := 0;
1879 ToDo := Stream.Size;
1880 SetSize(ToDo);
1881 If ToDo <> 0 Then Stream.ReadBuffer(FBuffer^[0], ToDo);
1882End;
1883
1884Procedure TMemoryStream.LoadFromFile(Const FileName:String);
1885Var
1886 Source: TFileStream;
1887Begin
1888 Source := TFileStream.Create(FileName, Stream_OpenRead);
1889 Try
1890 LoadFromStream(Source);
1891 Finally
1892 Source.Destroy;
1893 End;
1894End;
1895
1896Procedure TMemoryStream.SaveToStream(Stream: TStream);
1897Begin
1898 If FSize <> 0 Then Stream.WriteBuffer(FBuffer^[0], FSize);
1899End;
1900
1901Procedure TMemoryStream.SaveToFile(Const FileName:String);
1902Var
1903 Dest: TFileStream;
1904Begin
1905 Dest := TFileStream.Create(FileName, Stream_Create);
1906 Try
1907 SaveToStream(Dest);
1908 Finally
1909 Dest.Destroy;
1910 End;
1911End;
1912
1913Procedure TMemoryStream.SetCapacity(NewCapacity: LongInt);
1914Begin
1915 If FCapacity=NewCapacity Then Exit;
1916 FBuffer := ReAllocMem(FBuffer, FCapacity, NewCapacity);
1917 FCapacity := NewCapacity;
1918 If FSize > FCapacity Then FSize := FCapacity;
1919 If FPosition > FSize Then FPosition := FSize;
1920End;
1921
1922Procedure TMemoryStream.SetSize(NewSize: LongInt);
1923Begin
1924 Clear;
1925 SetCapacity(NewSize);
1926 FSize := NewSize;
1927End;
1928
1929Procedure TMemoryStream.Clear;
1930Begin
1931 SetCapacity(0);
1932End;
1933
1934{
1935ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1936º º
1937º Speed-Pascal/2 Version 2.0 º
1938º º
1939º Speed-Pascal Component Classes (SPCC) º
1940º º
1941º This section: TList Class Implementation º
1942º º
1943º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1944º º
1945ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1946}
1947
1948Procedure TList.Error;
1949Begin
1950 Raise EListError.Create(LoadNLSStr(SListErrorText));
1951End;
1952
1953
1954Function TList.Get(Index:LongInt):Pointer;
1955Begin
1956 Result := Nil;
1957 If (Index < 0) Or (Index >= FCount) Then Error
1958 Else Result := FList^[Index];
1959End;
1960
1961
1962Procedure TList.Put(Index:LongInt;Item:Pointer);
1963Begin
1964 If (Index < 0) Or (Index >= FCount) Then Error
1965 Else FList^[Index] := Item;
1966End;
1967
1968
1969Procedure TList.Grow;
1970Var gr:LongInt;
1971Begin
1972 If FGrowth <= 0 Then
1973 Begin
1974 If FCapacity < 128 Then gr := 16
1975 Else gr := FCapacity Shr 3;
1976 End
1977 Else gr := FGrowth;
1978 SetCapacity(FCapacity + gr);
1979End;
1980
1981
1982Procedure TList.SetCapacity(NewCapacity:LongInt);
1983Var NewList:PPointerList;
1984Begin
1985 If (NewCapacity > MaxListSize) Or (NewCapacity < FCount) Then Error
1986 Else
1987 If NewCapacity <> FCapacity Then
1988 Begin
1989 If NewCapacity > 0 Then
1990 Begin
1991 GetMem(NewList, NewCapacity*SizeOf(Pointer));
1992 If FCount > 0 Then System.Move(FList^,NewList^,
1993 FCount*SizeOf(Pointer));
1994 End
1995 Else NewList := Nil;
1996 If FList<>Nil Then FreeMem(FList, FCapacity*SizeOf(Pointer));
1997 FCapacity := NewCapacity;
1998 FList := NewList;
1999 End;
2000End;
2001
2002
2003Procedure TList.SetCount(NewCount:LongInt);
2004Var I:LongInt;
2005Begin
2006 If NewCount=FCount Then Exit;
2007 If (NewCount > MaxListSize) Or (NewCount < 0) Then Error
2008 Else
2009 Begin
2010 If NewCount > FCapacity Then SetCapacity(NewCount);
2011 If NewCount < FCount Then
2012 Begin
2013 For I := NewCount To FCount-1 Do FreeItem(FList^[I]);
2014 End
2015 Else FillChar(FList^[FCount], (NewCount-FCount)*SizeOf(Pointer),0);
2016 FCount := NewCount;
2017 End;
2018End;
2019
2020
2021{--- Public part ------------------------------------------------------------}
2022
2023(* Clear the whole List And Destroy the List Object *)
2024Destructor TList.Destroy;
2025Begin
2026 Clear;
2027 Inherited Destroy;
2028End;
2029
2030
2031(* Clear the whole List And Release the allocated Memory *)
2032Procedure TList.Clear;
2033Begin
2034 SetCount(0);
2035 SetCapacity(0);
2036End;
2037
2038
2039(* Append A New Item At the End Of the List And return the New Index *)
2040Function TList.Add(Item:Pointer):LongInt;
2041Begin
2042 If FCount = FCapacity Then Grow;
2043 FList^[FCount] := Item;
2044 Inc(FCount);
2045 Result := FCount-1;
2046End;
2047
2048
2049(* Delete the Item And decrement the Count Of elements In the List *)
2050Procedure TList.Delete(Index:LongInt);
2051Begin
2052 If (Index < 0) Or (Index >= FCount) Then Error
2053 Else
2054 Begin
2055 FreeItem(FList^[Index]);
2056
2057 Dec(FCount);
2058 If Index <> FCount Then System.Move(FList^[Index + 1],FList^[Index],
2059 (FCount-Index)*SizeOf(Pointer));
2060 End;
2061End;
2062
2063
2064(* Remove the Item And decrement the Count Of elements In the List *)
2065Function TList.Remove(Item:Pointer):LongInt;
2066Begin
2067 Result := IndexOf(Item);
2068 If Result <> -1 Then Delete(Result);
2069End;
2070
2071
2072(* Release the Memory allocated by the Item *)
2073Procedure TList.FreeItem(Item:Pointer);
2074Begin
2075 If FOnFreeItem <> Nil Then FOnFreeItem(Self,Item);
2076End;
2077
2078
2079(* Cut the specified Range out Of the List (including both indices) *)
2080Procedure TList.Cut(Index1,Index2:LongInt);
2081Var I,Swap:LongInt;
2082Begin
2083 If (Index1 < 0) Or (Index1 >= FCount) Or
2084 (Index2 < 0) Or (Index2 >= FCount) Then Error
2085 Else
2086 Begin
2087 If Index2 < Index1 Then
2088 Begin
2089 Swap := Index1;
2090 Index1 := Index2;
2091 Index2 := Swap;
2092 End;
2093
2094 For I := Index1 To Index2 Do FreeItem(FList^[I]);
2095
2096 If Index2 <> FCount-1 Then System.Move(FList^[Index2+1],FList^[Index1],
2097 (FCount-Index2)*SizeOf(Pointer));
2098 Dec(FCount,Index2-Index1+1);
2099 End;
2100End;
2101
2102
2103(* Insert A New Item At the specified Position In the List *)
2104Procedure TList.Insert(Index:LongInt;Item:Pointer);
2105Begin
2106 If (Index < 0) Or (Index > FCount) Then Error
2107 Else
2108 Begin
2109 If FCount = FCapacity Then Grow;
2110 If Index <> FCount Then System.Move(FList^[Index],FList^[Index+1],
2111 (FCount-Index)*SizeOf(Pointer));
2112 FList^[Index] := Item;
2113 Inc(FCount);
2114 End;
2115End;
2116
2117
2118(* Exchange two Items In the List *)
2119Procedure TList.Exchange(Index1,Index2:LongInt);
2120Var Item:Pointer;
2121Begin
2122 Item := Get(Index1);
2123 Put(Index1, Get(Index2));
2124 Put(Index2, Item);
2125End;
2126
2127
2128(* Move an Item To A New Position In the List *)
2129Procedure TList.Move(CurIndex,NewIndex:LongInt);
2130Var Item:Pointer;
2131Begin
2132 If (CurIndex < 0) Or (CurIndex >= FCount) Or
2133 (NewIndex < 0) Or (NewIndex >= FCount) Then Error
2134 Else
2135 If CurIndex <> NewIndex Then
2136 Begin
2137 Item := FList^[CurIndex];
2138 If CurIndex < NewIndex
2139 Then System.Move(FList^[CurIndex+1], FList^[CurIndex],
2140 (NewIndex-CurIndex)*SizeOf(Pointer))
2141 Else System.Move(FList^[NewIndex], FList^[NewIndex+1],
2142 (CurIndex-NewIndex)*SizeOf(Pointer));
2143 FList^[NewIndex] := Item;
2144 End;
2145End;
2146
2147
2148(* return the Index Of an Item *)
2149Function TList.IndexOf(Item:Pointer):LongInt;
2150Begin
2151 For Result := 0 To FCount-1 Do
2152 If FList^[Result] = Item Then Exit;
2153 Result := -1;
2154End;
2155
2156
2157(* return the First Item In the List *)
2158Function TList.First:Pointer;
2159Begin
2160 Result := Get(0);
2161End;
2162
2163
2164(* return the Last Item In the List *)
2165Function TList.Last:Pointer;
2166Begin
2167 Result := Get(FCount-1);
2168End;
2169
2170
2171(* Expand the List If Capacity Is reached *)
2172Function TList.Expand:TList;
2173Begin
2174 If FCount = FCapacity Then Grow;
2175 Result := Self;
2176End;
2177
2178
2179(* Remove All Nil elements In the List *)
2180Procedure TList.Pack;
2181Var I:LongInt;
2182Begin
2183 For I := FCount-1 DownTo 0 Do
2184 If FList^[I] = Nil Then Delete(I);
2185End;
2186
2187
2188Procedure TList.Sort(Compare: TListSortCompare);
2189
2190 Procedure Swap(I, K: LongInt);
2191 Var
2192 Item: Pointer;
2193 Begin
2194 Item := FList^[I];
2195 FList^[I] := FList^[K];
2196 FList^[K] := Item;
2197 End;
2198
2199 Procedure Reheap(I, K: LongInt);
2200 Var
2201 J: LongInt;
2202 Begin
2203 J := I;
2204 While J Shl 1 < K Do
2205 Begin
2206 If Compare(FList^[J Shl 1 - 1], FList^[J Shl 1 + 1 - 1]) > 0 Then J := J Shl 1
2207 Else J := J Shl 1 + 1;
2208 End;
2209 If J Shl 1 = K Then J := K;
2210
2211 While Compare(FList^[I - 1], FList^[J - 1]) > 0 Do J := J Shr 1;
2212
2213 Swap(I - 1, J - 1);
2214 J := J Shr 1;
2215
2216 While J >= I Do
2217 Begin
2218 Swap(I - 1, J - 1);
2219 J := J Shr 1;
2220 End;
2221 End;
2222
2223Var
2224 I, C: LongInt;
2225Begin
2226 C := Count;
2227 For I := C Shr 1 DownTo 1 Do Reheap(I, C);
2228 For I := C DownTo 2 Do
2229 Begin
2230 Swap(0, I - 1);
2231 Reheap(1, I - 1);
2232 End;
2233End;
2234
2235Procedure TList.AddList(List:TList);
2236var
2237 Source: PPointerList;
2238 Dest: PPointerList;
2239Begin
2240 if FCount + List.FCount > FCapacity then
2241 Capacity := FCapacity + List.FCount;
2242
2243 Source := List.FList;
2244 Dest := ( FList + FCount * sizeof( pointer ) );
2245 System.Move( Source^,
2246 Dest^,
2247 List.FCount * sizeof( pointer ) );
2248 inc( FCount, List.FCount );
2249End;
2250
2251Procedure TList.Assign(List:TList);
2252Begin
2253 Clear;
2254 AddList(List);
2255End;
2256
2257{
2258ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2259º º
2260º Speed-Pascal/2 Version 2.0 º
2261º º
2262º Speed-Pascal Component Classes (SPCC) º
2263º º
2264º This section: TChainList Class Implementation º
2265º º
2266º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2267º º
2268ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2269}
2270
2271Procedure TChainList.Error;
2272Begin
2273 Raise EListError.Create(LoadNLSStr(SListErrorText));
2274End;
2275
2276
2277Function TChainList.Index2PLE(Index:LongInt):PChainListItem;
2278Var I:LongInt;
2279Begin
2280 If (Index < 0) Or (Index >= FCount) Then Result := Nil
2281 Else
2282 Begin
2283 Result := FList;
2284 For I := 0 To Index-1 Do Result := Result^.Next;
2285 If Result = Nil Then Exit;
2286 End;
2287End;
2288
2289
2290Function TChainList.Item2PLE(Item:Pointer):PChainListItem;
2291Begin
2292 Result := FList;
2293 While Result <> Nil Do
2294 Begin
2295 If Result^.Item = Item Then Exit;
2296 Result := Result^.Next;
2297 End;
2298End;
2299
2300
2301Function TChainList.PLE2Index(ple:PChainListItem):LongInt;
2302Var ple1:PChainListItem;
2303Begin
2304 Result := -1;
2305 ple1 := FList;
2306 While ple1 <> Nil Do
2307 Begin
2308 Inc(Result);
2309 If ple1 = ple Then Exit;
2310 ple1 := ple1^.Next;
2311 End;
2312 Result := -1;
2313End;
2314
2315
2316Function TChainList.Item2Index(Item:Pointer):LongInt;
2317Var ple:PChainListItem;
2318Begin
2319 Result := -1;
2320 ple := FList;
2321 While ple <> Nil Do
2322 Begin
2323 Inc(Result);
2324 If ple^.Item = Item Then Exit;
2325 ple := ple^.Next;
2326 End;
2327 Result := -1;
2328End;
2329
2330
2331Procedure TChainList.Connect(ple1,ple2:PChainListItem);
2332Begin
2333 If ple1 <> Nil Then ple1^.Next := ple2
2334 Else FList := ple2;
2335 If ple2 <> Nil Then ple2^.Prev := ple1
2336 Else FListEnd := ple1;
2337End;
2338
2339
2340Function TChainList.Get(Index:LongInt):Pointer;
2341Var ple:PChainListItem;
2342Begin
2343 ple := Index2PLE(Index);
2344 If ple = Nil Then Error;
2345 Result := ple^.Item;
2346End;
2347
2348
2349Procedure TChainList.Put(Index:LongInt;Item:Pointer);
2350Var ple:PChainListItem;
2351Begin
2352 ple := Index2PLE(Index);
2353 If ple = Nil Then Error;
2354 ple^.Item := Item;
2355End;
2356
2357
2358
2359Destructor TChainList.Destroy;
2360Begin
2361 Clear;
2362 Inherited Destroy;
2363End;
2364
2365
2366Procedure TChainList.Clear;
2367Var I:LongInt;
2368 ple,plenext:PChainListItem;
2369Begin
2370 ple := FList;
2371 For I := 0 To FCount-1 Do
2372 Begin
2373 FreeItem(ple^.Item);
2374
2375 plenext := ple^.Next;
2376 Dispose(ple);
2377 ple := plenext;
2378 End;
2379 FCount := 0;
2380 FList := Nil;
2381 FListEnd := Nil;
2382End;
2383
2384
2385Function TChainList.Add(Item:Pointer):LongInt;
2386Var plenew:PChainListItem;
2387Begin
2388 New(plenew);
2389 plenew^.Item := Item;
2390 plenew^.Next := Nil;
2391 Connect(FListEnd,plenew);
2392 FListEnd := plenew;
2393 Result := FCount;
2394 Inc(FCount);
2395End;
2396
2397
2398Function TChainList.Remove(Item:Pointer):LongInt;
2399Var I:LongInt;
2400 ple:PChainListItem;
2401Begin
2402 ple := FList;
2403 For I := 0 To FCount-1 Do
2404 Begin
2405 If ple^.Item = Item Then
2406 Begin
2407 FreeItem(ple^.Item);
2408
2409 Result := I;
2410 Connect(ple^.Prev,ple^.Next);
2411 Dispose(ple);
2412 Dec(FCount);
2413 Exit;
2414 End;
2415 ple := ple^.Next;
2416 End;
2417 Result := -1;
2418End;
2419
2420
2421Procedure TChainList.Delete(Index:LongInt);
2422Var ple:PChainListItem;
2423Begin
2424 ple := Index2PLE(Index);
2425 If ple = Nil Then Error;
2426
2427 FreeItem(ple^.Item);
2428
2429 Connect(ple^.Prev,ple^.Next);
2430 Dispose(ple);
2431 Dec(FCount);
2432End;
2433
2434
2435Procedure TChainList.FreeItem(Item:Pointer);
2436Begin
2437 If FOnFreeItem <> Nil Then FOnFreeItem(Self,Item);
2438End;
2439
2440
2441Function TChainList.First:Pointer;
2442Var ple:PChainListItem;
2443Begin
2444 ple := FList;
2445 If ple = Nil Then Error;
2446 Result := ple^.Item;
2447End;
2448
2449
2450Function TChainList.Last:Pointer;
2451Var ple:PChainListItem;
2452Begin
2453 ple := FListEnd;
2454 If ple = Nil Then Error;
2455 Result := ple^.Item;
2456End;
2457
2458
2459Function TChainList.IndexOf(Item:Pointer):LongInt;
2460Begin
2461 Result := Item2Index(Item);
2462End;
2463
2464
2465Procedure TChainList.Insert(Index:LongInt;Item:Pointer);
2466Var ple,plenew:PChainListItem;
2467Begin
2468 If Index < 0 Then Error;
2469 If Index > FCount Then Error;
2470
2471 ple := Index2PLE(Index);
2472 If ple <> Nil Then
2473 Begin
2474 New(plenew);
2475 plenew^.Item := Item;
2476 Connect(ple^.Prev,plenew);
2477 Connect(plenew,ple);
2478 Inc(FCount);
2479 End
2480 Else Add(Item);
2481End;
2482
2483
2484Procedure TChainList.Move(CurIndex,NewIndex:LongInt);
2485Var TempItem:Pointer;
2486Begin
2487 If CurIndex < 0 Then Error;
2488 If CurIndex >= FCount Then Error;
2489 If NewIndex < 0 Then Error;
2490 If NewIndex >= FCount Then Error;
2491 If CurIndex = NewIndex Then Exit;
2492
2493 TempItem := Get(CurIndex);
2494 Delete(CurIndex);
2495 Insert(NewIndex,TempItem);
2496End;
2497
2498
2499Procedure TChainList.Exchange(Index1,Index2:LongInt);
2500Var ple1,ple2:PChainListItem;
2501 TempItem:Pointer;
2502Begin
2503 ple1 := Index2PLE(Index1);
2504 ple2 := Index2PLE(Index2);
2505 If (ple1 = Nil) Or (ple2 = Nil) Then Error;
2506
2507 TempItem := ple1^.Item;
2508 ple1^.Item := ple2^.Item;
2509 ple2^.Item := TempItem;
2510End;
2511
2512
2513Procedure TChainList.Pack;
2514Var I:LongInt;
2515 ple,plenext:PChainListItem;
2516Begin
2517 ple := FList;
2518 For I := 0 To FCount-1 Do
2519 Begin
2520 plenext := ple^.Next;
2521 If ple^.Item = Nil Then
2522 Begin
2523 Connect(ple^.Prev,ple^.Next);
2524 Dispose(ple);
2525 Dec(FCount);
2526 End;
2527 ple := plenext;
2528 End;
2529End;
2530
2531
2532{ --- Utility FUNCTIONs For TStrItem --- }
2533
2534Function NewStrItem(Const AString: String; AObject: TObject): PStrItem;
2535Begin
2536 GetMem(Result, SizeOf(TObject) + Length(AString) + 1);
2537 Result^.FObject := AObject;
2538 Result^.FString := AString;
2539End;
2540
2541Procedure DisposeStrItem(P: PStrItem);
2542Begin
2543 FreeMem(P, SizeOf(TObject) + Length(P^.FString) + 1);
2544End;
2545
2546
2547{ --- TStrings --- }
2548
2549Procedure TStrings.Append(Const S: String);
2550Begin
2551 Add(S);
2552End;
2553
2554Procedure TStrings.Put(Index: LongInt; Const S: String);
2555Var Temp:TObject;
2556Begin
2557 Temp := GetObject(Index);
2558 Delete(Index);
2559 InsertObject(Index, S, Temp);
2560End;
2561
2562{$HINTS OFF}
2563Function TStrings.GetObject(Index: LongInt): TObject;
2564Begin
2565 Result := Nil;
2566End;
2567
2568Procedure TStrings.PutObject(Index: LongInt; AObject: TObject);
2569Begin
2570End;
2571{$HINTS ON}
2572
2573Function TStrings.Add(Const S: String): LongInt;
2574Begin
2575 Result := Count;
2576 Insert(Result, S);
2577End;
2578
2579Function TStrings.AddObject(Const S: String; AObject: TObject): LongInt;
2580Begin
2581 Result := Add(S);
2582 PutObject(Result, AObject);
2583End;
2584
2585Procedure TStrings.AddStrings(AStrings: TStrings);
2586Var
2587 I: LongInt;
2588Begin
2589 BeginUpdate;
2590 Try
2591 For I := 0 To AStrings.Count - 1 Do
2592 AddObject(AStrings.Get(I), AStrings.GetObject(I));
2593 Finally
2594 EndUpdate;
2595 End;
2596End;
2597
2598Procedure TStrings.Assign(AStrings: TStrings);
2599Begin
2600 If AStrings=Self Then Exit;
2601 BeginUpdate;
2602 Try
2603 Clear;
2604 If AStrings<>Nil Then AddStrings(AStrings);
2605 Finally
2606 EndUpdate;
2607 End;
2608End;
2609
2610Procedure TStrings.BeginUpdate;
2611Begin
2612 If FUpdateSemaphore = 0 Then SetUpdateState(True);
2613 Inc(FUpdateSemaphore);
2614End;
2615
2616Procedure TStrings.EndUpdate;
2617Begin
2618 Dec(FUpdateSemaphore);
2619 If FUpdateSemaphore = 0 Then SetUpdateState(False);
2620End;
2621
2622Function TStrings.Equals(AStrings: TStrings): Boolean;
2623Var
2624 N: LongInt;
2625Begin
2626 Result := False;
2627 If Count <> AStrings.Count Then Exit;
2628 For N := 0 To Count - 1 Do If Get(N) <> AStrings.Get(N) Then Exit;
2629 Result := True;
2630End;
2631
2632Procedure TStrings.Exchange(Index1, Index2: LongInt);
2633Var
2634 S: String;
2635 O: TObject;
2636Begin
2637 S := Get(Index1);
2638 O := GetObject(Index1);
2639 Put(Index1, Get(Index2));
2640 PutObject(Index1, GetObject(Index2));
2641 Put(Index2, S);
2642 PutObject(Index2, O);
2643End;
2644
2645Function TStrings.GetName(Index: LongInt): String;
2646Var
2647 P: Integer;
2648Begin
2649 Result := Get(Index);
2650 P := Pos('=', Result);
2651 System.Delete(Result, P, Length(Result) - P + 1);
2652End;
2653
2654Procedure SingleLineToBuffer(Const S: String; Var P: PChar);
2655Begin
2656 Move(S[1], P[0], Length(S));
2657 Inc(P, Length(S));
2658 P[0] := #13;
2659 P[1] := #10;
2660 Inc(P, 2);
2661End;
2662
2663Function TStrings.GetText: PChar;
2664Var
2665 N, BufSize: LongInt;
2666 BufPtr: PChar;
2667Begin
2668 BufSize := 1;
2669 For N := 0 To Count - 1 Do Inc(BufSize, Length(Get(N)) + 2);
2670 Result := StrAlloc(BufSize);
2671
2672 BufPtr := Result;
2673 For N := 0 To Count - 1 Do SingleLineToBuffer(Get(N), BufPtr);
2674 BufPtr[0] := #0;
2675End;
2676
2677Function TStrings.GetTextStr: AnsiString;
2678Var
2679 N, BufSize: LongInt;
2680 BufPtr: PChar;
2681Begin
2682 BufSize := 0;
2683 For N := 0 To Count - 1 Do Inc(BufSize, Length(Get(N)) + 2);
2684 SetLength(Result, BufSize);
2685 BufPtr := PChar(Result);
2686 For N := 0 To Count - 1 Do SingleLineToBuffer(Get(N), BufPtr);
2687End;
2688
2689Function TStrings.GetValue(Const Name: String): String;
2690Begin
2691 FindValue(Name, Result);
2692End;
2693
2694Function TStrings.FindValue(Const Name: String; Var Value: String): LongInt;
2695Var
2696 P: Integer;
2697Begin
2698 For Result := 0 To Count - 1 Do
2699 Begin
2700 Value := Get(Result);
2701 P := Pos('=', Value);
2702 If P <> 0 Then
2703 Begin
2704 If CompareText(Copy(Value, 1, P - 1), Name) = 0 Then
2705 Begin
2706 System.Delete(Value, 1, P);
2707 Exit;
2708 End;
2709 End;
2710 End;
2711 Result := -1;
2712 Value := '';
2713End;
2714
2715Function TStrings.IndexOfName(Const Name: String): LongInt;
2716Var
2717 P: Integer;
2718 S: String;
2719Begin
2720 For Result := 0 To Count - 1 Do
2721 Begin
2722 S := Get(Result);
2723 P := Pos('=', S);
2724 If CompareText(Copy(S, 1, P - 1), Name) = 0 Then Exit;
2725 End;
2726 Result := -1;
2727End;
2728
2729Function TStrings.IndexOf(Const S: String): LongInt;
2730Begin
2731 For Result := 0 To Count-1 Do If CompareText(Get(Result), S) = 0 Then Exit;
2732 Result := -1;
2733End;
2734
2735Function TStrings.IndexOfObject(AObject: TObject): LongInt;
2736Begin
2737 For Result := 0 To Count-1 Do If GetObject(Result) = AObject Then Exit;
2738 Result := -1;
2739End;
2740
2741Procedure TStrings.InsertObject(Index: LongInt; Const S: String; AObject: TObject);
2742Begin
2743 Insert(Index, S);
2744 PutObject(Index, AObject);
2745End;
2746
2747Procedure TStrings.LoadFromFile(Const FileName: String);
2748Var
2749 Source: TFileStream;
2750Begin
2751 Try
2752 Source := TFileStream.Create(FileName, Stream_OpenRead);
2753 Except
2754 Source.Destroy;
2755 Raise;
2756 End;
2757
2758 Try
2759 LoadFromStream(Source);
2760 Finally
2761 Source.Destroy;
2762 End;
2763End;
2764
2765Procedure TStrings.LoadFromStream(Stream: TStream);
2766Begin
2767 BeginUpdate;
2768 Clear;
2769 Try
2770 While Not Stream.EndOfData Do Add(Stream.ReadLn);
2771 Finally
2772 EndUpdate;
2773 End;
2774End;
2775
2776Procedure TStrings.Move(CurIndex, NewIndex: LongInt);
2777Var
2778 O: TObject;
2779 S: String;
2780Begin
2781 If CurIndex = NewIndex Then Exit;
2782 S := Get(CurIndex);
2783 O := GetObject(CurIndex);
2784 FPreventFree := True;
2785 Delete(CurIndex);
2786 InsertObject(NewIndex, S, O);
2787 FPreventFree := False;
2788End;
2789
2790Procedure TStrings.SaveToFile(Const FileName: String);
2791Var
2792 Dest: TFileStream;
2793Begin
2794 Try
2795 Dest := TFileStream.Create(FileName, Stream_Create);
2796 Except
2797 Dest.Destroy;
2798 Raise;
2799 End;
2800
2801 Try
2802 SaveToStream(Dest);
2803 Finally
2804 Dest.Destroy;
2805 End;
2806End;
2807
2808Procedure TStrings.SaveToStream(Stream: TStream);
2809Var
2810 N: LongInt;
2811Begin
2812 For N := 0 To Count - 1 Do Stream.WriteLn(Get(N));
2813End;
2814
2815Procedure TStrings.SetText(Text: PChar);
2816
2817 Function SingleLineFromBuffer(Var P: PChar): String;
2818 Var
2819 I: Integer;
2820 Q: PChar;
2821 Begin
2822 I := 0;
2823 Q := P;
2824 While Not (Q[0] In [#13, #10, #26, #0]) And (I < 255) Do
2825 Begin
2826 Inc(Q);
2827 Inc(I);
2828 End;
2829 StrMove(@Result[1], P, I);
2830 SetLength(Result, I);
2831 P := Q;
2832 If P[0] = #13 Then Inc(P);
2833 If P[0] = #10 Then Inc(P);
2834 End;
2835
2836Begin
2837 BeginUpdate;
2838 Try
2839 Clear;
2840 If Text<>Nil Then While Not (Text[0] In [#0, #26]) Do
2841 Begin
2842 Add(SingleLineFromBuffer(Text));
2843 End;
2844 Finally
2845 EndUpdate;
2846 End;
2847End;
2848
2849Procedure TStrings.SetTextStr(Const Value: AnsiString);
2850Begin
2851 SetText(PChar(Value));
2852End;
2853
2854{$HINTS OFF}
2855Procedure TStrings.SetUpdateState(Updating: Boolean);
2856Begin
2857End;
2858{$HINTS ON}
2859
2860Procedure TStrings.SetValue(Const Name, Value: String);
2861Var
2862 I: LongInt;
2863 S: String;
2864Begin
2865 I := FindValue(Name, S);
2866 If I < 0 Then
2867 Begin
2868 If Length(Value) <> 0 Then Add(Name + '=' + Value)
2869 End
2870 Else
2871 Begin
2872 If Length(Value) <> 0 Then Put(I, Name + '=' + Value)
2873 Else Delete(I);
2874 End;
2875End;
2876
2877{ --- TStringList --- }
2878
2879Constructor TStringList.Create;
2880Begin
2881 Inherited Create;
2882 FList := TList.Create;
2883 FCaseSensitive := False;
2884End;
2885
2886Destructor TStringList.Destroy;
2887Begin
2888 { Die folgenden zwei Zeilen sp„ter wieder „ndern }
2889 Pointer(FOnChanging) := Nil;
2890 Pointer(FOnChange) := Nil;
2891 Clear;
2892 FList.Destroy;
2893 FList := Nil;
2894 Inherited Destroy;
2895End;
2896
2897Function TStringList.Add(Const S: String): LongInt;
2898Begin
2899 If FSorted Then
2900 Begin
2901 If Find(S, Result) Then
2902 Begin
2903 Case FDuplicates Of
2904 dupIgnore: Exit;
2905 dupError: Raise EStringListError.Create(LoadNLSStr(SStringListDupeErrorText));
2906 End;
2907 End;
2908 End
2909 Else Result := Count;
2910 Changing;
2911 FList.Insert(Result, NewStrItem(S, Nil));
2912 changed;
2913End;
2914
2915Procedure TStringList.changed;
2916Begin
2917 If (FUpdateSemaphore = 0) And (FOnChange <> Nil) Then FOnChange(Self);
2918End;
2919
2920Procedure TStringList.Changing;
2921Begin
2922 If (FUpdateSemaphore = 0) And (FOnChanging <> Nil) Then FOnChanging(Self);
2923End;
2924
2925Procedure TStringList.Clear;
2926Var
2927 N: LongInt;
2928Begin
2929 If Count > 0 Then
2930 Begin
2931 Changing;
2932 FLockChange:=True;
2933 For N := Count - 1 DownTo 0 Do Delete(N);
2934 FLockChange:=False;
2935 changed;
2936 End;
2937End;
2938
2939Procedure TStringList.Delete(Index: LongInt);
2940Begin
2941 If FLockChange Then
2942 Begin
2943 FreeItem(GetObject(Index));
2944 DisposeStrItem(FList.Get(Index));
2945 FList.Delete(Index);
2946 End
2947 Else
2948 Begin
2949 Changing;
2950 If Not FPreventFree Then FreeItem(GetObject(Index));
2951 DisposeStrItem(FList.Get(Index));
2952 FList.Delete(Index);
2953 changed;
2954 End;
2955End;
2956
2957Procedure TStringList.FreeItem(AObject:TObject);
2958Begin
2959 If FOnFreeItem <> Nil Then FOnFreeItem(Self,AObject);
2960End;
2961
2962Procedure TStringList.Exchange(Index1, Index2: LongInt);
2963Begin
2964 Changing;
2965 FList.Exchange(Index1, Index2);
2966 changed;
2967End;
2968
2969Function TStringList.Find(Const S: String; Var Index: LongInt): Boolean;
2970Var
2971 Low, High: LongInt;
2972 CMP: Integer;
2973 DoCompare: Function(Const S, T: String): Integer;
2974
2975Begin
2976 If CaseSensitive Then DoCompare := CompareStr // No Ansi equiv
2977 Else DoCompare := AnsiCompareText;
2978
2979 If sorted Then
2980 Begin
2981 { binary Search }
2982 Low := 0;
2983 High := GetCount - 1;
2984 Index := 0;
2985 CMP := -1;
2986 While (CMP <> 0) And (Low <= High) Do
2987 Begin
2988 Index := (Low + High) Div 2;
2989 CMP := DoCompare(S, Get(Index));
2990 If CMP < 0 Then High := Index -1
2991 Else If CMP > 0 Then Low := Index + 1;
2992 End;
2993 If Low = Index + 1 Then Inc(Index);
2994 Result := (CMP = 0);
2995 End
2996 Else
2997 Begin
2998 { Linear Search }
2999 Index := 0;
3000 While (Index < Count) And (DoCompare(Get(Index), S) <> 0) Do Inc(Index);
3001 Result := (Index < Count);
3002 End;
3003End;
3004
3005Function TStringList.Get(Index: LongInt): String;
3006Begin
3007 Result := PStrItem(FList.Get(Index))^.FString;
3008End;
3009
3010Function TStringList.GetCount: LongInt;
3011Begin
3012 Result := FList.Count;
3013End;
3014
3015Function TStringList.GetObject(Index: LongInt): TObject;
3016Begin
3017 Result := PStrItem(FList.Get(Index))^.FObject;
3018End;
3019
3020Function TStringList.IndexOf(Const S: String): LongInt;
3021Begin
3022 If Not Find(S, Result) Then Result := -1;
3023End;
3024
3025Procedure TStringList.Insert(Index: LongInt; Const S: String);
3026Begin
3027 Changing;
3028 If FSorted Then Raise EListError.Create(LoadNLSStr(SStringListInsertErrorText))
3029 Else FList.Insert(Index, NewStrItem(S, Nil));
3030 changed;
3031End;
3032
3033Procedure TStringList.Put(Index: LongInt; Const S: String);
3034Var TempObj:TObject;
3035 pstr:PStrItem;
3036Begin
3037 Changing;
3038 pstr := FList.Get(Index);
3039 TempObj := pstr^.FObject;
3040 DisposeStrItem(pstr);
3041 FList.Put(Index, NewStrItem(S, TempObj));
3042 changed;
3043End;
3044
3045Procedure TStringList.PutObject(Index: LongInt; AObject: TObject);
3046Var
3047 P: PStrItem;
3048Begin
3049 P := FList.Get(Index);
3050 P^.FObject := AObject;
3051End;
3052
3053Procedure TStringList.BottomUpHeapSort;
3054Var
3055 DoCompare: Function (Const S, T: String): Integer;
3056
3057 Procedure Reheap(I, K: LongInt);
3058 Var
3059 J: LongInt;
3060 Begin
3061 J := I;
3062 While J Shl 1 < K Do
3063 Begin
3064 If DoCompare(Get(J Shl 1 - 1), Get(J Shl 1 + 1 - 1)) > 0 Then J := J Shl 1
3065 Else J := J Shl 1 + 1;
3066 End;
3067 If J Shl 1 = K Then J := K;
3068
3069 While DoCompare(Get(I - 1), Get(J - 1)) > 0 Do J := J Shr 1;
3070
3071 FList.Exchange(I - 1, J - 1);
3072 J := J Shr 1;
3073
3074 While J >= I Do
3075 Begin
3076 FList.Exchange(I - 1, J - 1);
3077 J := J Shr 1;
3078 End;
3079 End;
3080
3081Var
3082 I, C: LongInt;
3083Begin
3084 If CaseSensitive Then DoCompare := CompareStr
3085 Else DoCompare := CompareText;
3086
3087 C := Count;
3088 For I := C Shr 1 DownTo 1 Do Reheap(I, C);
3089 For I := C DownTo 2 Do
3090 Begin
3091 FList.Exchange(0, I - 1);
3092 Reheap(1, I - 1);
3093 End;
3094End;
3095
3096Procedure TStringList.SetCaseSensitive(Value: Boolean);
3097Var
3098 old: Boolean;
3099Begin
3100 Changing;
3101 old := FCaseSensitive;
3102 FCaseSensitive := Value;
3103 If FSorted And (FCaseSensitive <> old) Then Sort;
3104 changed;
3105End;
3106
3107Procedure TStringList.SetSorted(Value: Boolean);
3108Begin
3109 Changing;
3110 If (Not FSorted) And Value Then Sort;
3111 FSorted := Value;
3112 changed;
3113End;
3114
3115Procedure TStringList.SetUpdateState(Updating: Boolean);
3116Begin
3117 If Updating Then Changing
3118 Else changed;
3119End;
3120
3121Procedure TStringList.Sort;
3122Begin
3123 If Count > 1 Then
3124 Begin
3125 Changing;
3126 BottomUpHeapSort;
3127 changed;
3128 End;
3129End;
3130
3131Function TStringList.GetValuePtr(Index:Longint): PString;
3132var
3133 Item: PStrItem;
3134Begin
3135 Item := PStrItem(FList.Get(Index));
3136 Result := Addr( Item^.FString );
3137End;
3138
3139
3140{
3141ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3142º º
3143º Speed-Pascal/2 Version 2.0 º
3144º º
3145º Speed-Pascal Component Classes (SPCC) º
3146º º
3147º This section: Some useful FUNCTIONs º
3148º º
3149º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
3150º º
3151ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
3152}
3153
3154Function MessageBox2(Const Msg:String;Typ:TMsgDlgType;Buttons:TMsgDlgButtons):TMsgDlgReturn;
3155Var C,Title:cstring;
3156 iFlags:LongWord;
3157 mresult:LongWord;
3158Begin
3159 C:=Msg;
3160
3161 {$IFDEF OS2}
3162 iFlags:=MB_MOVEABLE OR MB_APPLMODAL;
3163
3164 If Typ=mtError Then
3165 Begin
3166 Title:=LoadNLSStr(SError);
3167 iFlags:=iFlags Or MB_ERROR;
3168 End
3169 Else If Typ=mtCritical Then
3170 Begin
3171 Title:=LoadNLSStr(SCriticalError);
3172 iFlags:=iFlags Or MB_CRITICAL;
3173 End
3174 Else If Typ=mtInformation Then
3175 Begin
3176 Title:=LoadNLSStr(sInformation);
3177 iFlags:=iFlags Or MB_INFORMATION;
3178 End
3179 Else If Typ=mtWarning Then
3180 Begin
3181 Title:=LoadNLSStr(SWarning);
3182 iFlags:=iFlags Or MB_WARNING;
3183 End
3184 Else If Typ=mtConfirmation Then
3185 Begin
3186 Title:=LoadNLSStr(SMessage);
3187 iFlags:=iFlags Or MB_ICONQUESTION;
3188 End
3189 Else
3190 Begin
3191 Title:=ParamStr(0);
3192 iFlags:=iFlags Or MB_NOICON;
3193 End;
3194
3195 If Buttons*[mbOk]<>[] Then
3196 Begin
3197 If Buttons*[mbCancel]<>[] Then iFlags:=iFlags Or MB_OKCANCEL
3198 Else iFlags:=iFlags Or MB_OK;
3199 End
3200 Else If Buttons*[mbCancel]<>[] Then
3201 Begin
3202 If Buttons*mbYesNo<>[] Then iFlags:=iFlags Or MB_YESNOCANCEL
3203 Else If Buttons*[mbRetry]<>[] Then iFlags:=iFlags Or MB_RETRYCANCEL
3204 Else iFlags:=iFlags Or MB_CANCEL;
3205 End
3206 Else If Buttons*[mbYes]<>[] Then
3207 Begin
3208 If Buttons*[mbNo]<>[] Then iFlags:=iFlags Or MB_YESNO
3209 Else iFlags:=iFlags Or MB_OK;
3210 End;
3211
3212 If Buttons*mbAbortRetryIgnore<>[] Then iFlags:=iFlags Or MB_ABORTRETRYIGNORE;
3213
3214 InitPM;
3215 mresult:=WinMessageBox(HWND_DESKTOP,HWND_DESKTOP,C,Title,0,iFlags);
3216
3217 Case mresult Of
3218 MBID_OK:Result:=mrOk;
3219 MBID_CANCEL:Result:=mrCancel;
3220 MBID_YES:Result:=mrYes;
3221 MBID_NO:Result:=mrNo;
3222 MBID_IGNORE:Result:=mrIgnore;
3223 MBID_ABORT:Result:=mrAbort;
3224 MBID_RETRY:Result:=mrRetry;
3225 Else Result:=mrCancel;
3226 End; {Case}
3227 {$ENDIF}
3228 {$IFDEF Win95}
3229 iFlags:=MB_TASKMODAL;
3230
3231 If Typ=mtError Then
3232 Begin
3233 Title:=LoadNLSStr(SError);
3234 iFlags:=iFlags Or MB_ICONHAND;
3235 End
3236 Else If Typ=mtCritical Then
3237 Begin
3238 Title:=LoadNLSStr(SCriticalError);
3239 iFlags:=iFlags Or MB_ICONHAND;
3240 End
3241 Else If Typ=mtInformation Then
3242 Begin
3243 Title:=LoadNLSStr(sInformation);
3244 iFlags:=iFlags Or MB_ICONEXCLAMATION;
3245 End
3246 Else If Typ=mtWarning Then
3247 Begin
3248 Title:=LoadNLSStr(SWarning);
3249 iFlags:=iFlags Or MB_ICONEXCLAMATION;
3250 End
3251 Else If Typ=mtConfirmation Then
3252 Begin
3253 Title:=LoadNLSStr(SMessage);
3254 iFlags:=iFlags Or MB_ICONQUESTION;
3255 End
3256 Else
3257 Begin
3258 Title:=ParamStr(0);
3259 End;
3260
3261 If Buttons*[mbOk]<>[] Then
3262 Begin
3263 If Buttons*[mbCancel]<>[] Then iFlags:=iFlags Or MB_OKCANCEL
3264 Else iFlags:=iFlags Or MB_OK;
3265 End
3266 Else If Buttons*[mbCancel]<>[] Then
3267 Begin
3268 If Buttons*mbYesNo<>[] Then iFlags:=iFlags Or MB_YESNOCANCEL
3269 Else If Buttons*[mbRetry]<>[] Then iFlags:=iFlags Or MB_RETRYCANCEL
3270 Else iFlags:=iFlags Or MB_OK; //MB_CANCEL only Not present
3271 End
3272 Else If Buttons*[mbYes]<>[] Then
3273 Begin
3274 If Buttons*[mbNo]<>[] Then iFlags:=iFlags Or MB_YESNO
3275 Else iFlags:=iFlags Or MB_OK;
3276 End;
3277
3278 If Buttons*mbAbortRetryIgnore<>[] Then iFlags:=iFlags Or MB_ABORTRETRYIGNORE;
3279
3280 mresult:=WinUser.MessageBox(0,C,Title,iFlags);
3281
3282 Case mresult Of
3283 IDOK:Result:=mrOk;
3284 IDCANCEL:Result:=mrCancel;
3285 IDYES:Result:=mrYes;
3286 IDNO:Result:=mrNo;
3287 IDIGNORE:Result:=mrIgnore;
3288 IDABORT:Result:=mrAbort;
3289 IDRETRY:Result:=mrRetry;
3290 Else Result:=mrCancel;
3291 End; {Case}
3292 {$ENDIF}
3293End;
3294
3295
3296Function ErrorBox2(Const Msg:String):TMsgDlgReturn;
3297Begin
3298 Beep(1000,200);
3299 Result:=MessageBox2(Msg,mtError,[mbOk]);
3300End;
3301
3302
3303
3304{
3305ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3306º º
3307º Speed-Pascal/2 Version 2.0 º
3308º º
3309º Speed-Pascal Component Classes (SPCC) º
3310º º
3311º This section: SCU File format types And records º
3312º º
3313º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
3314º º
3315ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
3316}
3317
3318Type
3319 PResourceEntry=^TResourceEntry;
3320 TResourceEntry=Record
3321 ResName:TResourceName;
3322 DataOffset:LongInt;
3323 DataLen:LongInt;
3324 End;
3325
3326Function CompareResMem(Var Buf1,Buf2;Size:LongWord):Boolean;
3327Var R:Boolean;
3328Begin
3329 Asm
3330 CLD
3331 MOV ESI,Buf1
3332 MOV EDI,Buf2
3333 MOV ECX,Size
3334 CLD
3335 REP
3336 CMPSB
3337 SETE AL
3338 MOV R,AL
3339 End;
3340 Result:=R;
3341End;
3342
3343{$HINTS OFF}
3344Function TResourceStream.NewResourceEntry(Const ResName:TResourceName;
3345 Var Data;DataLen:LongInt):Boolean;
3346Var dummy:PResourceEntry;
3347 SavePos,T,HeadPos:LongInt;
3348 P:Pointer;
3349Label L;
3350Begin
3351 Result:=False;
3352 If DataLen=0 Then Exit;
3353
3354 SavePos:=Position;
3355 HeadPos:=8; {Initial Resource Header}
3356 If FResourceList<>Nil Then
3357 Begin
3358 For T:=0 To FResourceList.Count-1 Do
3359 Begin
3360 dummy:=FResourceList.Items[T];
3361 If dummy^.ResName=ResName Then
3362 If dummy^.DataLen=DataLen Then
3363 Begin
3364 Position:=dummy^.DataOffset;
3365 P:=Pointer(FBuffer);
3366 Inc(P,Position);
3367 If CompareResMem(P^,Data,DataLen) Then
3368 Begin
3369 Position:=SavePos;
3370 SavePos:=dummy^.DataOffset;
3371 Goto L;
3372 End;
3373 End;
3374 Inc(HeadPos,SizeOf(TResourceEntry)); {Length Of Info}
3375 End;
3376 End;
3377 Position:=SavePos;
3378
3379 If Write(Data,DataLen)=0 Then Exit;
3380
3381 //reserve A Header entry
3382 HeadPos:=FHeaderPos;
3383 Inc(FHeaderPos,SizeOf(TResourceEntry)); {Length Of Info}
3384
3385 New(dummy);
3386
3387 dummy^.ResName:=ResName;
3388 dummy^.DataOffset:=SavePos;
3389 dummy^.DataLen:=DataLen;
3390
3391 If FResourceList=Nil Then FResourceList.Create;
3392 FResourceList.Add(dummy);
3393L:
3394 //Write Position Of Resource
3395 If SCUStream.Write(HeadPos,4)=0 Then Exit;
3396
3397 Result:=True;
3398End;
3399{$HINTS ON}
3400
3401Function TResourceStream.WriteResourcesToStream(Stream:TMemoryStream):Boolean;
3402Var T,t1:LongInt;
3403 PatchOffset,StartPos:LongInt;
3404 dummy:PResourceEntry;
3405 P:Pointer;
3406Begin
3407 Result:=False;
3408 If FResourceList=Nil Then
3409 Begin
3410 T:=0; //no resources
3411 If Stream.Write(T,4)=0 Then Exit;
3412 Result:=True;
3413 Exit;
3414 End;
3415
3416 StartPos:=Stream.Position;
3417
3418 T:=FResourceList.Count; //Count Of Resource entries
3419 If Stream.Write(T,4)=0 Then Exit;
3420
3421 PatchOffset:=Stream.Position;
3422 T:=0;
3423 If Stream.Write(T,4)=0 Then Exit; // Resource Data Offset patched later
3424
3425 For T:=0 To FResourceList.Count-1 Do
3426 Begin
3427 dummy:=FResourceList.Items[T];
3428 If Stream.Write(dummy^,SizeOf(TResourceEntry))=0 Then Exit;
3429 End;
3430
3431 //patch Offset To Resource Data
3432 T:=Stream.Position;
3433 Stream.Position:=PatchOffset;
3434 t1:=T-StartPos;
3435 If Stream.Write(t1,4)=0 Then Exit;
3436 Stream.Position:=T;
3437
3438 //Write Resource Data
3439
3440 P:=Memory;
3441 If Stream.Write(P^,Size)=0 Then Exit;
3442
3443 Result:=True;
3444End;
3445
3446Destructor TResourceStream.Destroy;
3447Var T:LongInt;
3448 dummy:PResourceEntry;
3449Begin
3450 If FResourceList<>Nil Then
3451 Begin
3452 For T:=0 To FResourceList.Count-1 Do
3453 Begin
3454 dummy:=FResourceList.Items[T];
3455 Dispose(dummy);
3456 End;
3457 FResourceList.Destroy;
3458 FResourceList := Nil;
3459 End;
3460
3461 Inherited Destroy;
3462End;
3463
3464Type
3465 TPropertyTyp=(TPropString,TPropSet,TPropLongInt,TPropEnum,
3466 TPropClass);
3467
3468 PSCUPropInit=^TSCUPropInit;
3469 TSCUPropInit=Record
3470 PropertyName:String;
3471 PropertySize:LongInt;
3472 PropertyTyp:TPropertyTyp;
3473 PropertyValue:Pointer;
3474 End;
3475
3476 PSCUDesc=^TSCUDesc;
3477 TSCUDesc=Record
3478 NextEntryOffset:LongInt;
3479 ClassName:String; //subclassed Class Name
3480 BaseClassName:String; //base Class Name For designer
3481 PropertyCount:LongInt; //Count Of properties To initialize
3482 properties:PSCUPropInit;
3483 End;
3484
3485{
3486ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3487º º
3488º Speed-Pascal/2 Version 2.0 º
3489º º
3490º Speed-Pascal Component Classes (SPCC) º
3491º º
3492º This section: TPersistent Class Implementation º
3493º º
3494º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
3495º º
3496ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
3497}
3498
3499Procedure TPersistent.AssignError(Source:TPersistent);
3500Var Msg:String;
3501Begin
3502 If Source=Nil Then Msg:='Nil'
3503 Else Msg:=Source.ClassName;
3504 Raise EConvertError.Create('Convert '+ClassName+' to '+Msg+'.');
3505End;
3506
3507Procedure TPersistent.AssignTo(Dest:TPersistent);
3508Begin
3509 Dest.AssignError(Self);
3510End;
3511
3512Procedure TPersistent.Assign(Source:TPersistent);
3513Begin
3514 If Source<>Nil Then Source.AssignTo(Self)
3515 Else AssignError(nil);
3516End;
3517
3518
3519{
3520ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3521º º
3522º Speed-Pascal/2 Version 2.0 º
3523º º
3524º Speed-Pascal Component Classes (SPCC) º
3525º º
3526º This section: TComponent Class Implementation º
3527º º
3528º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
3529º º
3530ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
3531}
3532
3533Const //OldStyleFormat:Boolean=False;
3534 LastSCUForm:TComponent=Nil;
3535
3536Function GetClassNameFromSCU(NameTable:Pointer;Namep:LongWord):String;
3537Var ps:^String;
3538Begin
3539 ps:=NameTable;
3540 Inc(ps,Namep);
3541 Result:=ps^;
3542End;
3543
3544Function GetParentSCUFormDesign(Component:TComponent):TComponent;
3545Var AOwner:TComponent;
3546Begin
3547 Result:=Nil;
3548 AOwner:=Component;
3549
3550 //Search For First parent that has Is A Form And TypeName match
3551 While AOwner <> Nil Do
3552 Begin
3553 //If AOwner.IDESCU_Data<>Nil Then
3554 If csForm In AOwner.ComponentState Then
3555 Begin
3556 Result:=AOwner;
3557 Exit;
3558 End;
3559
3560 AOwner:=AOwner.FOwner;
3561 End;
3562 Result := Nil; //Error
3563End;
3564
3565Function GetParentSCUFormRuntime(Component:TComponent;Name:String):TComponent;
3566Var AOwner:TComponent;
3567 S:String;
3568Begin
3569 Result:=Nil;
3570 AOwner:=Component;
3571 UpcaseStr(Name);
3572
3573 //Search For First parent that has TypeName match
3574 While AOwner <> Nil Do
3575 Begin
3576 S:=AOwner.ClassName;
3577 UpcaseStr(S);
3578 If S=Name Then
3579 Begin
3580 Result:=AOwner;
3581 Exit;
3582 End;
3583 AOwner:=AOwner.FOwner;
3584 End;
3585 Result := Nil; //Error
3586End;
3587
3588Procedure InsertSCUMethod(AParent,Objekt:TComponent;
3589 ProcName,ProcParams,PropertyName:String);
3590Var Methods:PIDE_Methods;
3591 S,s2:String[64];
3592 s1,s3:String;
3593 Own:PIDE_OwnerList;
3594Label L;
3595Begin
3596 S:=ProcName;
3597 UpcaseStr(S);
3598 s1:=ProcParams;
3599 UpcaseStr(s1);
3600 s2:=PropertyName;
3601 UpcaseStr(s2);
3602
3603 //look If method Is still here
3604 Methods:=AParent.FMethods;
3605 While Methods<>Nil Do
3606 Begin
3607 s3:=Methods^.Name^;
3608 UpcaseStr(s3);
3609 If s3=S Then //ProcNames match
3610 Begin
3611 s3:=Methods^.Params^;
3612 UpcaseStr(s3);
3613 If s3=s1 Then //Parameters match --> only Add To List
3614 Begin
3615 Goto L;
3616 End;
3617 End;
3618
3619 Methods:=Methods^.Next;
3620 End;
3621
3622 //Insert New Item
3623 New(Methods);
3624 Methods^.Next:=AParent.FMethods;
3625 AParent.FMethods:=Methods;
3626
3627 AssignStr(Methods^.Name,ProcName);
3628 AssignStr(Methods^.Params,ProcParams);
3629 Methods^.Owners.Create;
3630L:
3631 New(Own);
3632 AssignStr(Own^.PropertyName,PropertyName);
3633 Own^.Objekt:=Objekt;
3634 Methods^.Owners.Add(Own);
3635End;
3636
3637Function GetSCUProcParamsFromName(Objekt:TComponent;PropertyName:String):String;
3638Var p1:^LongWord;
3639 B:Byte;
3640 S,s1:String;
3641 ps:^String;
3642 pParent:Pointer;
3643 Scope:Byte;
3644 NameIndex:LongInt;
3645 NameTable:^String;
3646Label L,ex,again;
3647Begin
3648 //Search PropertyName
3649 UpcaseStr(PropertyName);
3650 p1:=Objekt.ClassInfo;
3651again:
3652 //overread Object Size
3653 Inc(p1,4);
3654 pParent:=Pointer(p1^);
3655 Inc(p1,8); //onto First Property Name
3656 p1:=Pointer(p1^);
3657 Inc(p1,4); //overread End Ptr
3658 NameTable:=Pointer(p1^); //Name Table Of Class
3659 Inc(p1,4); //overread Name Table poinzer
3660
3661 NameIndex:=p1^ And 255;
3662 Inc(p1);
3663 While NameIndex<>0 Do
3664 Begin
3665 s1[0]:=Chr(NameIndex);
3666 Move(p1^,s1[1],NameIndex);
3667 Inc(p1,NameIndex);
3668
3669 Scope:=p1^ And 255;
3670 Inc(p1);
3671 If Scope And 16=16 Then //stored ??
3672 Begin
3673 UpcaseStr(s1);
3674 If s1=PropertyName Then //found
3675 Begin
3676 p1:=Pointer(p1^); //Type information
3677
3678 //overread Property access Info
3679 If p1^ And 255<>0 Then Inc(p1,5)
3680 Else Inc(p1);
3681 If p1^ And 255<>0 Then Inc(p1,5)
3682 Else Inc(p1);
3683
3684 //overread Property Type len
3685 Inc(p1,4);
3686
3687 //Get Property Type
3688 B:=p1^ And 255;
3689 If Not (B In [PropType_ProcVar,PropType_FuncVar]) Then Goto ex; //Error
3690 Inc(p1);
3691 Goto L;
3692 End;
3693 End;
3694
3695 Inc(p1,4); //overread Type information Pointer
3696 NameIndex:=p1^ And 255;
3697 Inc(p1);
3698 End;
3699
3700 If pParent<>Nil Then
3701 Begin
3702 p1:=pParent;
3703 Inc(p1,4);
3704 p1:=Pointer(p1^); //ClassInfo
3705 Goto again;
3706 End;
3707ex:
3708 Result:='?';
3709 Exit; //Not found;
3710L:
3711 NameIndex:=p1^;
3712 Inc(p1,4);
3713 S:='';
3714 While NameIndex<>0 Do
3715 Begin
3716 If S<>'' Then S:=S+';';
3717 ps:=NameTable+NameIndex;
3718 s1:=ps^;
3719
3720 B:=p1^ And 255;
3721 Inc(p1);
3722 Case B Of
3723 1:s1:='VAR '+s1;
3724 2:;
3725 3:s1:='CONST '+s1;
3726 End;
3727
3728 S:=S+s1;
3729 NameIndex:=p1^; //TypeName
3730 Inc(p1,4);
3731 If NameIndex<>0 Then
3732 Begin
3733 ps:=NameTable+NameIndex;
3734 s1:=ps^;
3735 S:=S+':'+s1;
3736 End;
3737
3738 NameIndex:=p1^;
3739 Inc(p1,4);
3740 End; //While
3741
3742 If S<>'' Then Result:='('+S+');'
3743 Else Result:=S;
3744End;
3745
3746
3747Type PPropertyLink=^TPropertyLink;
3748 TPropertyLink=Record
3749 SelfPtr:TComponent;
3750 Owner:TComponent;
3751 WriteTyp:Byte;
3752 WriteOffset:LongInt;
3753 //WriteName:String[64];
3754 LinkName:String[64];
3755 Next:PPropertyLink;
3756 End;
3757
3758Const PropertyLinks:PPropertyLink=Nil;
3759
3760
3761Function GetPropertyTypeInfo2(Instance:TComponent;PropertyName:String;Var Info:TPropertyTypeInfo):Boolean;
3762Var L,C:^LongWord;
3763 ps:^String;
3764 S:String;
3765Label weiter;
3766Begin
3767 Result:=False;
3768 UpcaseStr(PropertyName);
3769
3770 L:=Pointer(Instance);
3771 L:=Pointer(L^); //VMT address
3772 While L<>Nil Do
3773 Begin
3774 Inc(L,4);
3775 L:=Pointer(L^); //Class Info
3776 C:=L;
3777 Inc(L,12);
3778 L:=Pointer(L^); //Property Info
3779 Inc(L,4);
3780 Info.NameTable:=Pointer(L^);
3781 Inc(L,4); //Start Of properties
3782 ps:=Pointer(L);
3783 While ps^[0]<>#0 Do
3784 Begin
3785 If ps^[0]=PropertyName[0] Then //found !!
3786 Begin
3787 S:=ps^;
3788 UpcaseStr(S);
3789 If S=PropertyName Then
3790 Begin
3791 Result:=True;
3792 Inc(L,Ord(ps^[0])+1); //skip Name
3793 Info.Scope:=L^ And 255;
3794
3795 Inc(L);
3796 L:=Pointer(L^); //Type And access Info
3797
3798 If ((Info.Scope And 24=0)Or(L=Nil)) Then
3799 Begin
3800 L:=Pointer(ps);
3801 Goto weiter; //Search also parent !
3802 End;
3803
3804 Info.PropInfo:=Pointer(L);
3805 Info.Read.Kind:=L^ And 255;
3806 Inc(L);
3807 If Info.Read.Kind<>0 Then
3808 Begin
3809 Info.Read.VarOffset:=L^;
3810 Inc(L,4);
3811 End;
3812 Info.Write.Kind:=L^ And 255;
3813 Inc(L);
3814 If Info.Write.Kind<>0 Then
3815 Begin
3816 Info.Write.VarOffset:=L^;
3817 Inc(L,4);
3818 End;
3819 Info.Size:=L^;
3820 Inc(L,4);
3821 Info.TypeInfo:=Pointer(L);
3822 Info.Typ:=L^ And 255;
3823
3824 Exit;
3825 End;
3826 End;
3827weiter:
3828 Inc(L,Ord(ps^[0])+6); //skip This entry
3829 ps:=Pointer(L);
3830 End;
3831
3832 Inc(C,4);
3833 L:=Pointer(C^); //parent VMT Or Nil
3834 End;
3835End;
3836
3837
3838Function GetReference(Owner:TComponent):TComponent;
3839Begin
3840 Result:=Owner.FReference;
3841End;
3842
3843Procedure SetReference(Owner,Ref:TComponent);
3844Begin
3845 Owner.FReference:=Ref;
3846End;
3847
3848
3849{$HINTS OFF}
3850Procedure TComponent.UpdateLinkList(Const PropertyName:String;LinkList:TList);
3851Begin
3852 //LinkList Is A List Of TComponent Instances that the Inspector
3853 //will display For the specified Property, you may only Remove Items !
3854End;
3855{$HINTS ON}
3856
3857
3858Type SCUTypes=(SCUNull,SCUByte,SCUWord,SCULongWord,SCUShortInt,SCUInteger,SCULongInt,SCUSingle,
3859 SCUDouble,SCUExtended,SCUByteBool,SCUWordBool,SCULongBool,SCUString,
3860 SCUCString,SCURecord,SCUSet4,SCUSet32,SCUEnum,SCUProcVar,SCUFuncVar,SCUClassVar,
3861 SCULink,SCUClass,SCUChar,SCUBinary);
3862
3863
3864{$HINTS OFF}
3865Function TComponent.ReadPropertiesSCU(COwner:TComponent;Namep,Resourcep:Pointer;Var ClassPointer:Pointer):Boolean;
3866Var P,p2:^LongInt;
3867 B:Byte;
3868 tt,TypeLen:LongInt;
3869 Typ:Byte;
3870 WriteTyp:Byte;
3871 WriteOffset,PropNameOffset:LongInt;
3872 Value,Temp:Pointer;
3873 TypeName,ProcName,PropertyName:String[64];
3874 ProcParams:String;
3875 ActComponentClass:TComponentClass;
3876 Proc:Pointer;
3877 AParent:TComponent;
3878 dummy:PPropertyLink;
3879 Error:Boolean;
3880 Info:TPropertyTypeInfo;
3881 InheritedComp:TComponent;
3882 SectionLen:LongWord;
3883 SCUTyp:SCUTypes;
3884Label L,err;
3885Begin
3886 Result:=False;
3887 P:=ClassPointer;
3888 SectionLen:=P^;
3889 Inc(P,4); //overread Property section len
3890L:
3891 Error:=False;
3892 B:=P^ And 255; //properties avail ?
3893 Inc(P);
3894 If ((B=1)Or(B=2)) Then
3895 Begin
3896 //there follows A Property entry - we are At Name Index
3897 PropNameOffset:=P^;
3898 Inc(P,4);
3899
3900 SCUTyp:=SCUNull;
3901 System.Move(P^,SCUTyp,1);
3902 Inc(P);
3903 If ((SCUTyp=SCURecord)Or(SCUTyp=SCUBinary)) Then
3904 Begin
3905 System.Move(P^,TypeLen,4);
3906 Inc(P,4);
3907 End;
3908
3909 PropertyName:=GetClassNameFromSCU(Namep,PropNameOffset);
3910 If Not GetPropertyTypeInfo2(Self,PropertyName,Info) Then
3911 Begin
3912 //evtll schon beim Rausschreiben skippen
3913 ErrorBox2(FmtLoadNLSStr(SPropertyNotFound,[PropertyName,ClassName])+' !'#13+
3914 LoadNLSStr(SPropertySkipped));
3915 Case SCUTyp Of
3916 SCUByte,SCUShortInt,SCUByteBool,SCUChar:Inc(P,1);
3917 SCUWord,SCUInteger,SCUWordBool:Inc(P,2);
3918 SCULongWord,SCULongInt,SCULongBool,SCUSingle:Inc(P,4);
3919 SCUDouble:Inc(P,8);
3920 SCUExtended:Inc(P,10);
3921 SCUString:Inc(P,(P^ And 255)+1);
3922 SCUCString:
3923 Begin
3924 While (P^ And 255)<>0 Do Inc(P);
3925 Inc(P); //skip #0
3926 End;
3927 SCULink:Inc(P,4); //Name Index
3928 SCURecord,SCUBinary:Inc(P,TypeLen);
3929 SCUSet4:Inc(P,4);
3930 SCUSet32:Inc(P,32);
3931 SCUEnum:Inc(P,4);
3932 SCUProcVar,SCUFuncVar:Inc(P,12); //Owner,method,Property Name Index
3933 {SCUClassVar:Inc(P,4);
3934 SCUClass:Inc(P,4);}
3935 Else Goto err; //Error !
3936 End;
3937 Goto L; //Until All properties Read
3938err:
3939 Inc(ClassPointer,SectionLen);
3940 Result:=True;
3941 Exit;
3942 End;
3943
3944 TypeLen:=Info.Size;
3945 Typ:=Info.Typ;
3946 WriteTyp:=Info.Write.Kind;
3947 WriteOffset:=Info.Write.VarOffset;
3948
3949 Case WriteTyp Of
3950 1,2,3:;
3951 Else If Typ<>PropType_Class Then
3952 Begin
3953 ErrorBox2(FmtLoadNLSStr(SPropertyReadOnly,[PropertyName])+'. '+
3954 LoadNLSStr(SPropertySkipped)+'.');
3955 Error:=True;
3956 End;
3957 End; {Case}
3958
3959 If B=2 Then //Link
3960 Begin
3961 Typ:=PropType_Link;
3962 End;
3963
3964 If Typ=PropType_String Then //String
3965 Begin
3966 B:=P^ And 255;
3967 TypeLen:=B+1;
3968 End;
3969
3970 Case Typ Of
3971 PropType_Class: //Class
3972 Begin
3973 //Get Value Of the Property
3974 Case Info.Read.Kind Of
3975 1:
3976 Begin
3977 GetMem(Value,TypeLen);
3978 p2:=Pointer(Self);
3979 Inc(p2,Info.Read.VarOffset);
3980 Move(p2^,Value^,TypeLen);
3981 End;
3982 2,3:
3983 Begin
3984 GetMem(Value,TypeLen);
3985 If Not CallReadProp(Self,Pointer(Info.Read.VarOffset),Typ,TypeLen,Value) Then
3986 Begin
3987 ErrorBox2('SCU Error 3: '+FmtLoadNLSStr(SCouldNotReadFromProperty,[PropertyName])+'.');
3988 FreeMem(Value,TypeLen);
3989 Exit;
3990 End;
3991 End;
3992 Else
3993 Begin
3994 ErrorBox2(FmtLoadNLSStr(SCouldNotReadFromProperty,[PropertyName])+'.');
3995 Goto err;
3996 End;
3997 End;
3998
3999 System.Move(Value^,InheritedComp,4);
4000 If InheritedComp=Nil Then
4001 Begin
4002 ErrorBox2('Property '+Name+'.'+PropertyName+' is NIL');
4003 FreeMem(Value,TypeLen);
4004 Goto err;
4005 End;
4006
4007 If Not InheritedComp.ReadPropertiesSCU(COwner,Namep,Resourcep,P) Then
4008 Begin
4009 ErrorBox2('Property '+Name+'.'+PropertyName+' could not be initialized');
4010 FreeMem(Value,TypeLen);
4011 Goto err;
4012 End;
4013 Error:=True; {!!}
4014 End;
4015 PropType_ProcVar,PropType_FuncVar: //ProcVar,FuncVar
4016 Begin
4017 tt:=P^;
4018 Inc(P,4);
4019 TypeName:='T'+GetClassNameFromSCU(Namep,tt);
4020 tt:=P^;
4021 Inc(P,4);
4022 ProcName:=GetClassNameFromSCU(Namep,tt);
4023 tt:=P^;
4024 Inc(P,4);
4025 PropertyName:=GetClassNameFromSCU(Namep,tt);
4026
4027 If TypeLen<>8 Then Exit; //Of Object !!
4028
4029 GetMem(Value,TypeLen);
4030
4031 If ((InsideDesigner)Or(InsideLanguageDesigner)) Then
4032 Begin
4033 //Owner IDESCU_Data suchen !
4034 AParent:=GetParentSCUFormDesign(Self);
4035 If AParent=Nil Then Exit; //Error
4036 //Proc In AParent IDESCU_Data einfgen
4037
4038 ProcParams:=GetSCUProcParamsFromName(Self,PropertyName);
4039 If ProcParams='?' Then
4040 Begin
4041 ErrorBox2(FmtLoadNLSStr(SPropError,[PropertyName]));
4042 Error:=True;
4043 End
4044 Else InsertSCUMethod(AParent,Self,ProcName,ProcParams,PropertyName);
4045 FillChar(Value^,TypeLen,0); {!!}
4046 End
4047 Else
4048 Begin
4049 //Search For TypeName.ProcName
4050 //dazu In SetupSCU alle Forms mit RegisterClasses registrieren
4051 ActComponentClass:=SearchClassByName(TypeName);
4052 If ActComponentClass=Nil Then
4053 Begin
4054 ErrorBox2('SCU Error 1: '+FmtLoadNLSStr(SComponentNotFound,[TypeName])+'.'#13+
4055 LoadNLSStr(SUseRegisterClasses));
4056 Error:=True;
4057 End
4058 Else
4059 Begin
4060 //Get Object For that method
4061 AParent:=GetParentSCUFormRuntime(Self,TypeName);
4062 If AParent=Nil Then
4063 Begin
4064 ErrorBox2(FmtLoadNLSStr(SSCUErrorInClass,[TypeName]));
4065 Error:=True;
4066 End
4067 Else
4068 Begin
4069 Proc:=AParent.MethodAddress(ProcName);
4070 If Proc=Nil Then
4071 Begin
4072 ErrorBox2(FmtLoadNLSStr(SMethodNotFound,[ProcName,ClassName]));
4073 Error:=True;
4074 End
4075 Else
4076 Begin
4077 //Proc Adresse setzen
4078 Move(Proc,Value^,4);
4079 Inc(Value,4);
4080 //method Object Pointer setzen
4081 Move(AParent,Value^,4);
4082 Dec(Value,4);
4083 End;
4084 End;
4085 End;
4086 End;
4087 End;
4088 PropType_Link: //Link
4089 Begin
4090 If ComponentState*[csForm]<>[] Then
4091 If PropertyName='Menu' Then
4092 Begin
4093 Include(ComponentState,csHasMainMenu);
4094 End;
4095
4096 //Name Of Property To Link
4097 tt:=P^;
4098 Inc(P,4);
4099 PropertyName:=GetClassNameFromSCU(Namep,tt);
4100
4101 If PropertyLinks=Nil Then
4102 Begin
4103 New(PropertyLinks);
4104 dummy:=PropertyLinks;
4105 dummy^.Next:=Nil;
4106 End
4107 Else
4108 Begin
4109 New(dummy);
4110 dummy^.Next:=PropertyLinks;
4111 PropertyLinks:=dummy;
4112 End;
4113 dummy^.SelfPtr:=Self;
4114 dummy^.Owner:=COwner;
4115 dummy^.WriteTyp:=WriteTyp;
4116 dummy^.WriteOffset:=WriteOffset;
4117 dummy^.LinkName:=PropertyName;
4118 Goto L; //dont Write here
4119 End;
4120 Else
4121 Begin
4122 GetMem(Value,TypeLen);
4123 Move(P^,Value^,TypeLen);
4124 Inc(P,TypeLen);
4125 End;
4126 End; {Case}
4127
4128 If Not Error Then
4129 Case WriteTyp Of
4130 1:
4131 Begin
4132 p2:=Pointer(Self);
4133 Inc(p2,WriteOffset);
4134 Move(Value^,p2^,TypeLen);
4135 End;
4136 2,3:
4137 Begin
4138 If Not CallWriteProp(Self,Pointer(WriteOffset),Typ,TypeLen,Value) Then
4139 Begin
4140 ErrorBox2('SCU Error 3: '+FmtLoadNLSStr(SCouldNotWriteToProperty,[PropertyName])+' !');
4141 End;
4142 End;
4143 Else Goto err; //Some Error
4144 End;
4145
4146 FreeMem(Value,TypeLen);
4147
4148 Goto L; //Until All properties Read
4149 End
4150 Else If B<>0 Then Exit; //Some Error
4151 ClassPointer:=P;
4152 Result:=True;
4153End;
4154{$HINTS ON}
4155
4156
4157Procedure TComponent.ReadResourceSCU(ResourceTable:Pointer;Var ClassP:Pointer);
4158Var DataOfs:LongWord;
4159 P:^LongWord;
4160 ps:PString;
4161 ResName:TResourceName;
4162 Data:Pointer;
4163 DataLen:LongInt;
4164 pp:^LongWord;
4165 DOfs:LongWord;
4166 reshead:LongWord;
4167Label L;
4168Begin
4169L:
4170 pp:=ClassP;
4171 Inc(ClassP,4);
4172 reshead:=pp^;
4173 If reshead=0 Then Exit; {no resources For This Component}
4174
4175 P:=ResourceTable+4; //onto Resource Data Offset
4176 DataOfs:=P^;
4177
4178 P:=ResourceTable;
4179 Inc(P,reshead); {Offset To Resource Header}
4180
4181 {process Resource Header}
4182 ps := PString(P);
4183 ResName := TResourceName(ps^);
4184 Inc(P,SizeOf(TResourceName));
4185 Data:=ResourceTable;
4186 DOfs:=P^;
4187 Inc(Data,DataOfs+DOfs); //Start Of Resource information
4188 Inc(P,4);
4189 DataLen:=P^;
4190 Inc(P,4);
4191 //Load resources For This Component
4192 ReadSCUResource(ResName,Data^,DataLen);
4193 Goto L; {Until no more resources For This}
4194End;
4195
4196
4197Procedure HandlePropertyLinks(Component:TComponent);
4198Var dummy,Next:PPropertyLink;
4199 P,p2:Pointer;
4200 T,t1:LongInt;
4201 Comp,Comp1,Comp2:TComponent;
4202 S:String;
4203Label found,again;
4204Begin
4205 dummy:=PropertyLinks;
4206 While dummy<>Nil Do
4207 Begin
4208 UpcaseStr(dummy^.LinkName);
4209 P:=Nil;
4210 Comp1:=Component;
4211again:
4212 For T:=0 To Comp1.ComponentCount-1 Do
4213 Begin
4214 Comp:=Comp1.Components[T];
4215
4216 If csReferenceControl In Comp.ComponentState Then continue;
4217
4218 If Comp Is TComponent Then
4219 Begin
4220 S:=Comp.Name;
4221 UpcaseStr(S);
4222 If S=dummy^.LinkName Then
4223 Begin
4224 P:=@Comp;
4225 Goto found;
4226 End;
4227 End;
4228
4229 For t1:=0 To Comp.ComponentCount-1 Do
4230 Begin
4231 Comp2:=Comp.Components[t1];
4232
4233 If csReferenceControl In Comp2.ComponentState Then continue;
4234
4235 If Comp2 Is TComponent Then
4236 Begin
4237 S:=Comp2.Name;
4238 UpcaseStr(S);
4239 If S=dummy^.LinkName Then
4240 Begin
4241 P:=@Comp2;
4242 Goto found;
4243 End;
4244 End;
4245 End;
4246 End;
4247
4248 Comp1:=Comp1.Owner;
4249 If Comp1<>Nil Then Goto again;
4250found:
4251 If P<>Nil Then
4252 Begin
4253 Case dummy^.WriteTyp Of
4254 1:
4255 Begin
4256 p2:=Pointer(dummy^.SelfPtr);
4257 Inc(p2,dummy^.WriteOffset);
4258 Move(P^,p2^,4);
4259 End;
4260 2,3: //method call (direct Or VMT)
4261 Begin
4262 If Not CallWriteProp(dummy^.SelfPtr,Pointer(dummy^.WriteOffset),PropType_Unsigned,4,P) Then
4263 Begin
4264 End;
4265 End;
4266 End; {Case}
4267 End;
4268
4269 dummy:=dummy^.Next;
4270 End;
4271
4272 dummy:=PropertyLinks;
4273 While dummy<>Nil Do
4274 Begin
4275 If dummy^.SelfPtr=Nil Then
4276 Begin
4277 ErrorBox2('SCU Error: '+FmtLoadNLSStr(SLinkNotFound,[dummy^.LinkName])+' !');
4278 End;
4279
4280 If ((dummy^.SelfPtr<>Nil)And(dummy^.SelfPtr.FComponentState*[csLoaded]=[])) Then
4281 Begin
4282 dummy^.SelfPtr.LoadedFromSCU(dummy^.Owner);
4283 dummy^.SelfPtr.Loaded;
4284 End;
4285
4286 Next:=dummy^.Next;
4287 Dispose(dummy);
4288 dummy:=Next;
4289 End;
4290
4291 PropertyLinks:=Nil;
4292End;
4293
4294
4295Function TComponent.ReadComponentsSCU(NameTable,ResourceTable:Pointer;Var ClassP:Pointer):Boolean;
4296Var ChildCount,T:LongInt;
4297 NameIndex,NameIndex1:LongInt;
4298 ComponentClass:TComponentClass;
4299 Component:TComponent;
4300 S,s1:String[64];
4301 ClassPointer:^LongWord;
4302 B:Byte;
4303 P:Pointer;
4304 RemoveReferenceButton:Boolean;
4305 ChildIsReferenceButton:Boolean;
4306 SavePropertyLinks,dummy:PPropertyLink;
4307 idx:LongInt;
4308 Ref:TComponent;
4309 LastReference:TComponent;
4310
4311 Procedure SkipChildComponents;
4312 Var t1,Count:LongInt;
4313 B:Byte;
4314 Begin
4315 Count:=ClassPointer^;
4316 Inc(ClassPointer,4);
4317 For t1:=1 To Count Do //skip All Child Components
4318 Begin
4319 Inc(ClassPointer,4); //skip Name Index
4320 B:=ClassPointer^ And 255;
4321 Inc(ClassPointer);
4322 If B=1 Then {runtime Class Name differs from Inspector Class Name}
4323 Begin
4324 Inc(ClassPointer,4); //skip NameIndex
4325 End;
4326
4327 {overread Property section}
4328 Inc(ClassPointer,ClassPointer^);
4329
4330 {overread Components section}
4331 SkipChildComponents; //overread All Child Components
4332
4333 {overread Resource section}
4334 While ClassPointer^<>0 Do Inc(ClassPointer,4);
4335 Inc(ClassPointer,4); {overread 0}
4336 End;
4337 End;
4338
4339Label skip,skipIt;
4340Begin
4341 Result:=False;
4342 SavePropertyLinks:=PropertyLinks;
4343 PropertyLinks:=Nil;
4344 ClassPointer:=ClassP;
4345 ChildCount:=ClassPointer^;
4346 Inc(ClassPointer,4);
4347 LastReference:=Nil;
4348 For T:=1 To ChildCount Do
4349 Begin
4350 NameIndex:=ClassPointer^;
4351 Inc(ClassPointer,4);
4352 S:=GetClassNameFromSCU(NameTable,NameIndex); {Of the New Child}
4353
4354 RemoveReferenceButton := False;
4355 ChildIsReferenceButton := False;
4356 If S = 'TReferenceWindow' Then
4357 Begin
4358 ChildIsReferenceButton := True;
4359 If Not InsideDesigner Then RemoveReferenceButton := True;
4360 End;
4361 s1 := '';
4362
4363 {check If runtime Class Name Is avail}
4364 B:=ClassPointer^ And 255;
4365 Inc(ClassPointer);
4366 If B=1 Then {runtime Class Name differs from Inspector Class Name}
4367 Begin
4368 NameIndex1:=ClassPointer^;
4369 Inc(ClassPointer,4);
4370 s1:=GetClassNameFromSCU(NameTable,NameIndex1);
4371 {Use runtime Class Name To Create the Class}
4372 If Not ((InsideDesigner)Or(InsideLanguageDesigner)) Then
4373 If s1 <> '' Then S := s1; {!!}
4374 End;
4375
4376 {note: runtime Class Names MUST be registered In Form Unit Or
4377 main Program Of an Application !!}
4378
4379 If RemoveReferenceButton Then ComponentClass:=SearchClassByName('TCONTROL')
4380 Else ComponentClass:=SearchClassByName(S);
4381
4382 If ComponentClass=Nil Then
4383 Begin
4384 ErrorBox2('SCU Error 2: '+FmtLoadNLSStr(SComponentNotFound,[S])+'.'#13 +
4385 LoadNLSStr(SUseRegisterClasses)+' !');
4386 Goto skipIt;
4387 End;
4388
4389 {C R E A T E the Child Object}
4390 FCreateFromSCU := True;
4391 Component := ComponentClass.Create(LastSCUForm);
4392 FCreateFromSCU := False;
4393
4394 {zur Sicherheit}
4395 If ChildIsReferenceButton Then
4396 If Not RemoveReferenceButton Then
4397 Begin {Predecessor Is the Reference -> Set the flag}
4398 idx := LastSCUForm.IndexOfComponent(LastReference);
4399 If idx >= 0 Then
4400 Begin
4401 Ref := LastSCUForm.Components[idx];
4402 Include(Ref.ComponentState, csReference); {!}
4403 End;
4404 End;
4405
4406 Component.SetDesigning(InsideDesigner Or InsideLanguageDesigner);
4407 Component.LoadingFromSCU(Self);
4408
4409 If ((InsideDesigner)Or(InsideLanguageDesigner)) Then
4410 {Set TypeName And IDESCU_Data}
4411 If s1<>'' Then
4412 Begin
4413 Component.TypeName:=s1;
4414 Component.FMethods:=Nil; {no Methods defined}
4415 End;
4416
4417 If RemoveReferenceButton Then
4418 Begin
4419 Component.Destroy; {besser gar nicht erst erzeugen}
4420skipIt:
4421 {overread Property section}
4422 Inc(ClassPointer,ClassPointer^);
4423
4424 {overread Components section}
4425 SkipChildComponents; //overread All Child Components
4426
4427 {overread Resource section}
4428 While ClassPointer^<>0 Do Inc(ClassPointer,4);
4429 Inc(ClassPointer,4); {overread 0}
4430
4431 continue;
4432 End
4433 Else
4434 Begin
4435 If Not Component.ReadPropertiesSCU(Self,NameTable,ResourceTable,ClassPointer) Then Exit;
4436 If Not Component.ReadComponentsSCU(NameTable,ResourceTable,ClassPointer) Then Exit;
4437 Component.ReadResourceSCU(ResourceTable,ClassPointer);
4438 End;
4439
4440
4441 If Not ((InsideDesigner)Or(InsideLanguageDesigner)) Then
4442 Begin
4443 {Set Object variable If present}
4444 P := LastSCUForm.FieldAddress(Component.Name);
4445 If P <> Nil Then Move(Component,P^,4);
4446 End;
4447
4448 //If This Component expects A Link Then we don't call Loaded unless the
4449 //Link Is established
4450 dummy:=PropertyLinks;
4451 While dummy<>Nil Do
4452 Begin
4453 If dummy^.SelfPtr=Component Then Goto skip;
4454 dummy:=dummy^.Next;
4455 End;
4456
4457 If Component.FComponentState*[csLoaded]=[] Then
4458 Begin
4459 If ChildIsReferenceButton Then
4460 Begin
4461 //Set the Reference
4462 Component.FReference:=LastReference;
4463 Include(LastReference.ComponentState,csReference);
4464 Component.LoadedFromSCU(Self);
4465 End
4466 Else Component.LoadedFromSCU(Self);
4467 Component.Loaded;
4468 End;
4469skip:
4470 //This Is the Last Reference Window
4471 //we have To Store it because it may contain Child Items...
4472 LastReference:=Component;
4473 End;
4474
4475 If PropertyLinks<>Nil Then
4476 Begin
4477 dummy:=PropertyLinks;
4478 While dummy^.Next<>Nil Do dummy:=dummy^.Next;
4479 dummy^.Next:=SavePropertyLinks; {Append}
4480 End
4481 Else PropertyLinks:=SavePropertyLinks;
4482
4483 ClassP:=ClassPointer;
4484 Result:=True;
4485End;
4486
4487
4488Function SearchClassSCU(Data:Pointer;NameToFind:String;ObjectCount:LongInt;ClassUnit:String):Pointer;
4489Var dummy:^LongWord;
4490 len:LongWord;
4491 Count:LongInt;
4492 ps:^String;
4493 S,D,N,E:String;
4494Label L;
4495Begin
4496 Result:=Nil;
4497 Count:=0;
4498 UpcaseStr(ClassUnit);
4499L:
4500 If Count>=ObjectCount Then Exit;
4501 dummy:=Data;
4502 len:=dummy^; //len Of This entry
4503 Inc(dummy,4); //onto Inspector Class Name
4504 Inc(dummy,(dummy^ And 255)+1); //overread Inspector Name
4505 ps:=Pointer(dummy); //runtime Class Name
4506 S:=ps^;
4507 UpcaseStr(S);
4508 If S=NameToFind Then
4509 Begin
4510 Inc(ps,Length(S)+1); //ON Unit Name
4511 S:=ps^;
4512 UpcaseStr(S);
4513 FSplit(S,D,N,E);
4514 If N=ClassUnit Then
4515 Begin
4516 Result:=Data;
4517 Exit;
4518 End;
4519 End;
4520
4521 Inc(Data,len); //Next entry
4522 Inc(Count);
4523 Goto L;
4524End;
4525
4526
4527Procedure TComponent.SetupSCU;
4528Var
4529 SaveSCU:Pointer;
4530 OldInsideDesigner:Boolean;
4531Begin
4532 If SCUPointer=Nil Then Exit;
4533 If ComponentState * [csForm] = [] Then Exit;
4534
4535 OldInsideDesigner:=InsideDesigner;
4536 SaveSCU:=SCUPointer;
4537 SCUPointer:=Nil; //prevent recursion
4538 Try
4539 ReadSCU(SaveSCU);
4540 Except
4541 On E:Exception Do
4542 If ((InsideDesigner)Or(InsideLanguageDesigner)) Then ErrorBox2('Illegal SCU format:'+E.Message);
4543 End;
4544
4545 SCUPointer:=SaveSCU;
4546 InsideDesigner:=OldInsideDesigner;
4547End;
4548
4549
4550{$HINTS OFF}
4551Procedure TComponent.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
4552Begin
4553End;
4554
4555Function TComponent.WriteSCUResource(Stream:TResourceStream):Boolean;
4556Begin
4557 Result:=True;
4558End;
4559
4560Procedure TComponent.LoadedFromSCU(SCUParent:TComponent);
4561Begin
4562 Exclude(FComponentState, csReading);
4563 Exclude(FComponentState, csLoading);
4564 Include(FComponentState, csLoaded);
4565End;
4566
4567Procedure TComponent.LoadingFromSCU(SCUParent:TComponent);
4568Begin
4569 Include(FComponentState, csReading);
4570 Include(FComponentState, csLoading);
4571 Exclude(FComponentState, csLoaded);
4572End;
4573{$HINTS ON}
4574
4575Procedure TComponent.Loaded;
4576Begin
4577End;
4578
4579
4580Procedure TComponent.SetupComponent;
4581Begin
4582 //Name := 'Component';
4583 Name := Copy(ClassName,2,255);
4584 Tag := 0;
4585 If Designed Then Include(ComponentState,csReference);
4586End;
4587
4588
4589Constructor TComponent.Create(AOwner:TComponent);
4590Begin
4591 //Inherited Create;
4592
4593 If InsideWriteSCUAdr^ Then Include(ComponentState, csWriting);
4594
4595 If AOwner Is TComponent Then AOwner.InsertComponent(Self);
4596
4597 SetupComponent;
4598End;
4599
4600
4601Procedure SetupFormSCU(Form:TComponent);
4602Begin
4603 If SCUPointer <> Nil Then Form.SetupSCU;
4604End;
4605
4606
4607Procedure TComponent.Notification(AComponent:TComponent;Operation:TOperation);
4608Var I:LongInt;
4609Begin
4610 If (FFreeNotifyList <> Nil) And (Operation = opRemove) Then
4611 Begin
4612 FFreeNotifyList.Remove(AComponent);
4613 If FFreeNotifyList.Count = 0 Then
4614 Begin
4615 FFreeNotifyList.Destroy;
4616 FFreeNotifyList := Nil;
4617 End;
4618 End;
4619
4620 For I := 0 To ComponentCount-1 Do
4621 Begin
4622 Components[I].Notification(AComponent,Operation);
4623 End;
4624End;
4625
4626
4627Procedure TComponent.FreeNotification(AComponent:TComponent);
4628Begin
4629 If FFreeNotifyList = Nil Then FFreeNotifyList.Create;
4630
4631 If FFreeNotifyList.IndexOf(AComponent) < 0 Then
4632 Begin
4633 FFreeNotifyList.Add(AComponent);
4634 AComponent.FreeNotification(Self);
4635 End;
4636End;
4637
4638
4639Function GetLanguages(Component:TComponent):PLanguageInfo;
4640Begin
4641 Result:=Component.FLanguages;
4642End;
4643
4644Procedure SetLanguages(Component:TComponent;Info:PLanguageInfo);
4645Begin
4646 Component.FLanguages:=Info;
4647End;
4648
4649Procedure FreeLanguage(Var LangComp:PLanguageComponent);
4650Var NextLangComp:PLanguageComponent;
4651Begin
4652 While LangComp<>Nil Do
4653 Begin
4654 FreeMem(LangComp^.Name,Length(LangComp^.Name^)+1);
4655 If LangComp^.ValueLen>0 Then
4656 FreeMem(LangComp^.Value,LangComp^.ValueLen);
4657
4658 NextLangComp:=LangComp^.Next;
4659 Dispose(LangComp);
4660 LangComp:=NextLangComp;
4661 End;
4662End;
4663
4664Destructor TComponent.Destroy;
4665Var Meth,Last:PIDE_Methods;
4666 T:LongInt;
4667 Own:PIDE_OwnerList;
4668 I:LongInt;
4669 LangItem,NextLangItem:PLanguageItem;
4670Begin
4671 {inform All linked Components}
4672 If FFreeNotifyList <> Nil Then
4673 Begin
4674 For I := 0 To FFreeNotifyList.Count-1 Do
4675 Begin
4676 TComponent(FFreeNotifyList[I]).Notification(Self,opRemove);
4677 End;
4678 FFreeNotifyList.Destroy;
4679 FFreeNotifyList := Nil;
4680 End;
4681
4682 Meth:=FMethods;
4683 While Meth<>Nil Do
4684 Begin
4685 DisposeStr(Meth^.Name);
4686 DisposeStr(Meth^.Params);
4687 If Meth^.Owners<>Nil Then
4688 Begin
4689 For T:=0 To Meth^.Owners.Count-1 Do
4690 Begin
4691 Own:=Meth^.Owners.Items[T];
4692 DisposeStr(Own^.PropertyName);
4693 End;
4694 Meth^.Owners.Destroy;
4695 End;
4696
4697 Last:=Meth^.Next;
4698 Dispose(Meth);
4699 Meth:=Last;
4700 End;
4701 FMethods := Nil;
4702
4703 //Free registered languages
4704 If FLanguages<>Nil Then
4705 Begin
4706 LangItem:=PLanguageInfo(FLanguages)^.Items;
4707 FreeMem(FLanguages,SizeOf(TLanguageInfo));
4708 FLanguages:=Nil;
4709 While LangItem<>Nil Do
4710 Begin
4711 FreeMem(LangItem^.Name,Length(LangItem^.Name^)+1);
4712
4713 FreeLanguage(LangItem^.Components);
4714 FreeLanguage(LangItem^.Menus);
4715 FreeLanguage(LangItem^.StringTables);
4716
4717 NextLangItem:=LangItem^.Next;
4718 Dispose(LangItem);
4719 LangItem:=NextLangItem;
4720 End;
4721 End;
4722
4723
4724 DestroyComponents;
4725
4726 If FOwner <> Nil Then FOwner.RemoveComponent(Self);
4727
4728 DisposeStr(FName);
4729 FName := Nil;
4730 DisposeStr(FUnitName);
4731 FUnitName := Nil;
4732 DisposeStr(FTypeName);
4733 FTypeName := Nil;
4734
4735 Inherited Destroy;
4736End;
4737
4738
4739Procedure TComponent.DestroyComponents;
4740Var I:LongInt;
4741 Component:TComponent;
4742Begin
4743 If FComponents <> Nil Then
4744 Begin
4745 I := ComponentCount;
4746 While I > 0 Do
4747 Begin
4748 Component := Components[I-1];
4749 RemoveComponent(Component);
4750 Component.Destroy;
4751 I := ComponentCount;
4752 End;
4753
4754 FComponents.Destroy;
4755 FComponents := Nil;
4756 End;
4757End;
4758
4759Function TComponent.GetComponentIndex:LongInt;
4760Begin
4761 Result := -1;
4762 If FOwner = Nil Then Exit;
4763 If FOwner.FComponents = Nil Then Exit;
4764 Result := FOwner.FComponents.IndexOf(Self);
4765End;
4766
4767Procedure TComponent.SetComponentIndex(Index:LongInt);
4768Var I:LongInt;
4769Begin
4770 If FOwner = Nil Then Exit;
4771 I := FOwner.IndexOfComponent(Self);
4772 If I < 0 Then Exit;
4773 If Index = I Then Exit;
4774 If Index < 0 Then Index := 0;
4775 If Index >= FOwner.FComponents.Count
4776 Then Index := FOwner.FComponents.Count -1;
4777 FOwner.FComponents.Move(I,Index);
4778End;
4779
4780Function TComponent.GetComponentCount:LongInt;
4781Begin
4782 If FComponents=Nil Then Result:=0
4783 Else Result:=FComponents.Count;
4784End;
4785
4786Function TComponent.GetComponent(AIndex:LongInt):TComponent;
4787Begin
4788 If (FComponents=Nil) Or (AIndex<0) Or (AIndex>=FComponents.Count)
4789 Then Result:=Nil
4790 Else Result:=FComponents.Items[AIndex];
4791End;
4792
4793Function TComponent.GetName:String;
4794Begin
4795 If FName<>Nil Then Result:=FName^
4796 Else Result:='';
4797End;
4798
4799Procedure TComponent.SetName(Const NewName:String);
4800Begin
4801 AssignStr(FName,NewName);
4802End;
4803
4804Function TComponent.GetUnitName:String;
4805Begin
4806 If FUnitName <> Nil Then Result := FUnitName^
4807 Else Result := '';
4808End;
4809
4810Function TComponent.GetTypeName:String;
4811Begin
4812 If FTypeName <> Nil Then Result := FTypeName^
4813 Else Result := '';
4814End;
4815
4816Procedure TComponent.SetTypeName(NewName:String);
4817Begin
4818 AssignStr(FTypeName,NewName);
4819End;
4820
4821Function TComponent.GetDesigned:Boolean;
4822Begin
4823 Result := FComponentState * [csDesigning] <> [];
4824End;
4825
4826Procedure TComponent.InsertComponent(AComponent:TComponent);
4827Begin
4828 If FComponents = Nil Then FComponents.Create;
4829 FComponents.Add(AComponent);
4830 AComponent.FOwner := Self;
4831
4832 AComponent.SetDesigning(Designed); {!}
4833
4834 Notification(AComponent,opInsert);
4835End;
4836
4837Procedure TComponent.RemoveComponent(AComponent:TComponent);
4838Begin
4839 Notification(AComponent,opRemove);
4840 If FComponents = Nil Then Exit;
4841 FComponents.Remove(AComponent);
4842End;
4843
4844Function TComponent.IndexOfComponent(AComponent:TComponent):LongInt;
4845Begin
4846 Result := -1;
4847 If FComponents = Nil Then Exit;
4848 Result := FComponents.IndexOf(AComponent);
4849End;
4850
4851Function TComponent.FindComponent(Const AName:String):TComponent;
4852Var I:LongInt;
4853Begin
4854 Result := Nil;
4855 For I := 0 To ComponentCount-1 Do
4856 If Components[I].Name = AName Then
4857 Begin
4858 Result := Components[I];
4859 break;
4860 End;
4861End;
4862
4863
4864Procedure TComponent.SetDesigning(Value:Boolean);
4865Var I:LongInt;
4866Begin
4867 If Value Then Include(FComponentState, csDesigning)
4868 Else Exclude(FComponentState, csDesigning);
4869
4870 For I := 0 To ComponentCount-1 Do Components[I].SetDesigning(Value);
4871End;
4872
4873
4874Procedure AddDesignerPopupEvent(AString:TStringList;Caption:String;Id:LongInt);
4875Begin
4876 If AString Is TStringList Then AString.AddObject(Caption, TObject(Id));
4877End;
4878
4879
4880{event from the designer PopupMenu}
4881{$HINTS OFF}
4882Procedure TComponent.GetDesignerPopupEvents(AString:TStringList);
4883Begin
4884End;
4885
4886Procedure TComponent.DesignerPopupEvent(Id:LongInt);
4887Begin
4888End;
4889{$HINTS ON}
4890
4891
4892{
4893ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
4894º º
4895º Speed-Pascal/2 Version 2.0 º
4896º º
4897º Speed-Pascal Component Classes (SPCC) º
4898º º
4899º This section: General FUNCTIONs Implementation º
4900º º
4901º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
4902º º
4903ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
4904}
4905
4906Const
4907 SearchCompLibComponentByName:Function(Const Name:String):TComponentClass=Nil;
4908 CallCompLibClassPropertyEditor:Function(Var ClassToEdit:TObject):TClassPropertyEditorReturn=Nil;
4909 CallCompLibPropertyEditor:Function(Owner:TComponent;PropertyName:String;Var Value;ValueLen:LongInt;
4910 Var List:TStringList):TPropertyEditorReturn=Nil;
4911 CallCompLibPropertyEditorAvailable:Function(OwnerClass:TClass;PropertyName:String):Boolean=Nil;
4912 CallCompLibClassPropertyEditorAvailable:Function(ClassName:String):Boolean=Nil;
4913
4914Var
4915 NameTable:TList;
4916
4917Function NameTableAdd(P:PString):LongInt;
4918Var T:LongInt;
4919 Ofs:LongInt;
4920 pp:PString;
4921Begin
4922 Ofs:=0;
4923 For T:=0 To NameTable.Count-1 Do
4924 Begin
4925 pp:=NameTable.Items[T];
4926 If pp^=P^ Then
4927 Begin
4928 Result:=Ofs;
4929 Exit;
4930 End;
4931 Inc(Ofs,Length(pp^)+1);
4932 End;
4933 NameTable.Add(P);
4934 Result:=Ofs;
4935End;
4936
4937
4938Function SearchClassByName(Const Name:String):TComponentClass;
4939Var T:LongInt;
4940 Comp:TComponentClass;
4941 S,s1:String;
4942Begin
4943 Result := Nil;
4944 S := Name;
4945 UpcaseStr(S);
4946 For T := 0 To RegisteredClasses.Count-1 Do
4947 Begin
4948 Comp := RegisteredClasses.Items[T];
4949 s1 := Comp.ClassName;
4950 UpcaseStr(s1);
4951 If s1 = S Then
4952 Begin
4953 Result := Comp;
4954 Exit;
4955 End;
4956 End;
4957
4958 {Search In registered Components Of the complib}
4959 If @SearchCompLibComponentByName<>Nil
4960 Then Result := SearchCompLibComponentByName(Name);
4961End;
4962
4963Procedure RegisterClass(Const ComponentClass:TComponentClass);
4964Var Comp:TComponentClass;
4965 t1:LongInt;
4966Begin
4967 For t1:=0 To RegisteredClasses.Count-1 Do
4968 Begin
4969 Comp:=RegisteredClasses.Items[t1];
4970 If Comp.ClassName=ComponentClass.ClassName Then exit;
4971 End;
4972
4973 RegisteredClasses.Add(ComponentClass);
4974End;
4975
4976Function GetClass(Const ClassName:String):TComponentClass;
4977Begin
4978 Result:=SearchClassByName(ClassName);
4979End;
4980
4981Function FindClass(Const ClassName:String):TComponentClass;
4982Begin
4983 Result:=GetClass(ClassName);
4984 If Result=Nil Then Raise EClassNotFound.Create(ClassName);
4985End;
4986
4987Procedure UnRegisterClass(AClass:TComponentClass);
4988Var t1:LongInt;
4989 Comp:TComponentClass;
4990Label again;
4991Begin
4992again:
4993 For t1:=0 To RegisteredClasses.Count-1 Do
4994 Begin
4995 Comp:=RegisteredClasses.Items[t1];
4996 If Comp.ClassName=AClass.ClassName Then
4997 Begin
4998 RegisteredClasses.Remove(Comp);
4999 goto again;
5000 End;
5001 End;
5002End;
5003
5004Procedure UnRegisterClasses(Const AClasses:Array of TComponentClass);
5005Var t:LongInt;
5006Begin
5007 For t:=0 To High(AClasses) Do UnRegisterClass(AClasses[t]);
5008End;
5009
5010
5011Procedure RegisterClasses(Const ComponentClasses: Array Of TComponentClass);
5012Var T,t1:LongInt;
5013 Comp,Comp1:TComponentClass;
5014Label l1;
5015Begin
5016 For T:=0 To High(ComponentClasses) Do
5017 Begin
5018 Comp1:=ComponentClasses[T];
5019 For t1:=0 To RegisteredClasses.Count-1 Do
5020 Begin
5021 Comp:=RegisteredClasses.Items[t1];
5022 If Comp.ClassName=Comp1.ClassName Then Goto l1;
5023 End;
5024
5025 RegisteredClasses.Add(Comp1);
5026l1:
5027 End;
5028End;
5029
5030{copies actual Value Of Property To Value.
5031 Value MUST be allocated With At least TypLen Bytes !}
5032Function CallReadProp(Objekt:TObject;FuncAddr:Pointer;Typ:Byte;
5033 TypLen:LongInt;Value:Pointer):Boolean;
5034Var
5035 FResult:LongInt;
5036 Func:Function(SelfObj:TObject):LongInt;
5037 FuncVar:Function(VarRef:Pointer;SelfObj:TObject):LongInt;
5038Begin
5039 Result:=False;
5040
5041 If FuncAddr=Nil Then Exit; //method Not found
5042
5043 If ((Typ=PropType_Set)And(TypLen=4)) Then Typ:=PropType_Unsigned;
5044
5045 If LongWord(FuncAddr)<65535 Then //VMT call
5046 Begin
5047 Case Typ Of
5048 PropType_Unsigned,PropType_Signed,PropType_Class,
5049 PropType_Enum,PropType_Boolean,PropType_Char,PropType_ClassVar:
5050 Begin
5051 Asm
5052 PUSH DWord Ptr Objekt //Self
5053 MOV EAX,FuncAddr //VMT Index
5054 CALLN32 System.!VmtCall
5055 MOV FResult,EAX
5056 End;
5057 Move(FResult,Value^,TypLen);
5058 End;
5059 PropType_Float,PropType_String,PropType_Set,PropType_CString,
5060 PropType_ProcVar,PropType_FuncVar,PropType_Record:
5061 Begin
5062 Asm
5063 PUSH DWord Ptr Value //Var Parameter Of return Value
5064 PUSH DWord Ptr Objekt //Self
5065 MOV EAX,FuncAddr //VMT Index
5066 CALLN32 System.!VmtCall
5067 End;
5068 End;
5069 Else Exit; //Some Error
5070 End; {Case}
5071 End
5072 Else
5073 Begin
5074 Case Typ Of
5075 PropType_Unsigned,PropType_Signed,PropType_Class,
5076 PropType_Enum,PropType_Boolean,PropType_Char,PropType_ClassVar:
5077 Begin
5078 Func:=FuncAddr;
5079 FResult:=Func(Objekt);
5080 Move(FResult,Value^,TypLen);
5081 End;
5082 PropType_Float,PropType_String,PropType_Set,PropType_CString,
5083 PropType_ProcVar,PropType_FuncVar,PropType_Record:
5084 Begin
5085 FuncVar:=FuncAddr;
5086 FResult:=FuncVar(Value,Objekt);
5087 End;
5088 Else Exit; //Some Error
5089 End; {Case}
5090 End;
5091
5092 Result:=True;
5093End;
5094
5095{copies actual Value Of Value To the Property.
5096 Value MUST be allocated With At least TypLen Bytes !}
5097Function CallWriteProp(Objekt:TObject;ProcAddr:Pointer;Typ:Byte;
5098 TypLen:LongInt;Value:Pointer):Boolean;
5099Var
5100 Proc:Procedure(Value:LongWord;SelfObj:TObject);
5101 ProcVar:Procedure(Value:Pointer;SelfObj:TObject);
5102 pb:^LongWord;
5103 pw:^Word;
5104 pl:^LongWord;
5105 L:LongWord;
5106Begin
5107 Result:=False;
5108
5109 If ProcAddr=Nil Then Exit; //method Not found
5110
5111 If TypLen In [1,2,3,4] Then
5112 If Not (Typ In [PropType_String,PropType_CString]) Then Typ:=PropType_Unsigned;
5113
5114 If LongWord(ProcAddr)<65535 Then //VMT call
5115 Begin
5116 Case Typ Of
5117 PropType_Unsigned,PropType_Signed,PropType_Class,
5118 PropType_Enum,PropType_Boolean,PropType_Char,PropType_ClassVar:
5119 Begin
5120 Case TypLen Of
5121 1:
5122 Begin
5123 pb:=Value;
5124 L:=pb^;
5125 End;
5126 2:
5127 Begin
5128 pw:=Value;
5129 L:=pw^;
5130 End;
5131 3:
5132 Begin
5133 L:=0;
5134 Move(pl^,L,3);
5135 End;
5136 4:
5137 Begin
5138 pl:=Value;
5139 L:=pl^;
5140 End;
5141 Else Exit; //no Valid Type Size For Val
5142 End; {Case}
5143
5144 Asm
5145 PUSH DWord Ptr L //Value To Set
5146 PUSH DWord Ptr Objekt //Self
5147 MOV EAX,ProcAddr //VMT Index
5148 CALLN32 System.!VmtCall
5149 End;
5150 End;
5151 PropType_Float,PropType_String,PropType_Set,PropType_CString,
5152 PropType_ProcVar,PropType_FuncVar,PropType_Record:
5153 Begin
5154 Asm
5155 PUSH DWord Ptr Value //Var Parameter Of Data To Assign
5156 PUSH DWord Ptr Objekt //Self
5157 MOV EAX,ProcAddr //VMT Index
5158 CALLN32 System.!VmtCall
5159 End;
5160 End;
5161 Else Exit; //Some Error
5162 End; {Case}
5163 End
5164 Else
5165 Begin
5166 Case Typ Of
5167 PropType_Unsigned,PropType_Signed,PropType_Class,
5168 PropType_Enum,PropType_Boolean,PropType_Char,PropType_ClassVar:
5169 Begin
5170 Proc:=ProcAddr;
5171 Case TypLen Of
5172 1:
5173 Begin
5174 pb:=Value;
5175 L:=pb^;
5176 End;
5177 2:
5178 Begin
5179 pw:=Value;
5180 L:=pw^;
5181 End;
5182 3:
5183 Begin
5184 L:=0;
5185 Move(pl^,L,3);
5186 End;
5187 4:
5188 Begin
5189 pl:=Value;
5190 L:=pl^;
5191 End;
5192 Else Exit; //no Valid Type Size For Val
5193 End; {Case}
5194
5195 Proc(L,Objekt);
5196 End;
5197 PropType_Float,PropType_String,PropType_Set,PropType_CString,
5198 PropType_ProcVar,PropType_FuncVar,PropType_Record:
5199 Begin
5200 ProcVar:=ProcAddr;
5201 ProcVar(Value,Objekt);
5202 End;
5203 Else Exit; //Some Error
5204 End; {Case}
5205 End;
5206
5207 Result:=True;
5208End;
5209
5210Var PropertyNameTable:Pointer;
5211
5212
5213Const SCUUnsignedTypes:Array[1..4] Of SCUTypes=(SCUByte,SCUWord,SCUNull,SCULongWord);
5214 SCUSignedTypes:Array[1..4] Of SCUTypes=(SCUShortInt,SCUInteger,SCUNull,SCULongInt);
5215 SCUFloatTypes:Array[4..10] Of SCUTypes=(SCUSingle,SCUNull,SCUNull,SCUNull,SCUDouble,SCUNull,SCUExtended);
5216 SCUBooleanTypes:Array[1..4] Of SCUTypes=(SCUByteBool,SCUWordBool,SCUNull,SCULongBool);
5217
5218Function WriteProperties(Stream:TMemoryStream;p1:Pointer;Objekt:TComponent;
5219 pParent:Pointer):Boolean; Forward;
5220
5221
5222Function WritePropertyValues(Stream:TMemoryStream;P:Pointer;Objekt:TComponent;
5223 Namep:Pointer;ReferenceObjekt:TComponent):Boolean;
5224Var Typep,p1,p2:^LongInt;
5225 Typ,B:Byte;
5226 tt,TypLen:LongInt;
5227 ReadTyp,WriteTyp:Byte;
5228 S:String;
5229 ps:^String;
5230 Value,ReferenceValue:^LongInt;
5231 ValueLen:LongInt;
5232 ReadOffset,WriteOffset:LongInt;
5233 s3:String;
5234 ReadAddr,WriteAddr:Pointer;
5235 ValidProp:Boolean;
5236 AOwner:TComponent;
5237 Methods:PIDE_Methods;
5238 Own:PIDE_OwnerList;
5239 MyComp:TComponent;
5240 pParent1:Pointer;
5241Label L,lll,lll1,ex,weiter;
5242Begin
5243 Result:=False;
5244 ValidProp:=True;
5245 p1:=P;
5246 MyComp:=Nil;
5247
5248 ReadTyp:=p1^ And 255;
5249 Inc(p1);
5250 Case ReadTyp Of
5251 0:; //Not avail
5252 1: //Var Offset
5253 Begin
5254 ReadOffset:=p1^;
5255 Inc(p1,4);
5256 End;
5257 2,3: //Procedure Or Function (direct Or VMT call)
5258 Begin
5259 ReadAddr:=Pointer(p1^);
5260 Inc(p1,4);
5261 End;
5262 Else Goto ex; //Some Error
5263 End;
5264
5265 WriteTyp:=p1^ And 255;
5266 Inc(p1);
5267 Case WriteTyp Of
5268 0:; //Not avail
5269 1: //Var Offset
5270 Begin
5271 WriteOffset:=p1^;
5272 Inc(p1,4);
5273 End;
5274 2,3: //Procedure Or Function (direct Or VMT call)
5275 Begin
5276 WriteAddr:=Pointer(p1^);
5277 Inc(p1,4);
5278 End;
5279 Else Goto ex; //Some Error
5280 End;
5281
5282 //determine Type Of the Property
5283 TypLen:=p1^;
5284 ValueLen:=TypLen;
5285 GetMem(Value,TypLen);
5286 GetMem(ReferenceValue,TypLen);
5287 Inc(p1,4);
5288 Typ:=p1^ And 255; //Property Type
5289 Typep:=p1;
5290
5291 //Write Value Of the Property
5292 Case ReadTyp Of
5293 0:; //Not avail
5294 1: //Var Offset
5295 Begin
5296 p2:=Pointer(Objekt);
5297 Inc(p2,ReadOffset);
5298 Move(p2^,Value^,TypLen);
5299 p2:=Pointer(ReferenceObjekt);
5300 Inc(p2,ReadOffset);
5301 Move(p2^,ReferenceValue^,TypLen);
5302 End;
5303 2,3: //Procedure Or Function (direct Or VMT call)
5304 Begin
5305 If Not CallReadProp(Objekt,ReadAddr,Typ,TypLen,Value) Then Goto ex;
5306 If Not CallReadProp(ReferenceObjekt,ReadAddr,Typ,TypLen,ReferenceValue) Then Goto ex;
5307 End;
5308 Else Goto ex; //Some Error
5309 End;
5310
5311 If ReadTyp In [1,2,3] Then
5312 Begin
5313 If Typ In [PropType_ProcVar,PropType_FuncVar,
5314 PropType_Class,PropType_ClassVar] Then //ON... properties
5315 //ClassVar And
5316 //Classes
5317 Begin
5318 Own:=Nil;
5319 If Value^=0 Then
5320 Begin
5321 If Typ In [PropType_ProcVar,PropType_FuncVar] Then //ON properties
5322 Begin
5323 //Search Owner
5324 AOwner:=Objekt;
5325 ps:=Namep;
5326 S:=ps^;
5327 UpcaseStr(S);
5328lll:
5329 While AOwner<>Nil Do
5330 Begin
5331 Methods:=AOwner.FMethods;
5332
5333 While Methods<>Nil Do
5334 Begin
5335 For tt:=0 To Methods^.Owners.Count-1 Do
5336 Begin
5337 Own:=Methods^.Owners.Items[tt];
5338 s3:=Own^.PropertyName^;
5339 UpcaseStr(s3);
5340 If S=s3 Then
5341 If Own^.Objekt=TComponent(Objekt) Then
5342 Begin //found
5343 Goto lll1;
5344 End;
5345 End;
5346
5347 Methods:=Methods^.Next;
5348 End;
5349weiter:
5350 AOwner:=AOwner.FOwner;
5351 Goto lll;
5352 End; //While AOwner<>Nil
5353
5354 Goto L; //Not found --> dont Write
5355 End
5356 Else Goto L; //dont Write
5357 End;
5358
5359 If Typ=PropType_Class Then {Class}
5360 Begin
5361 MyComp:=Pointer(Value^);
5362 If MyComp<>Nil Then
5363 If MyComp Is TComponent Then
5364 If MyComp.Designed Then
5365 If MyComp.ComponentState * [csHandleLinks] <> [] Then
5366 Begin
5367 Typ:=PropType_Link; //Link
5368 Goto lll1;
5369 End;
5370
5371 If MyComp Is TComponent Then
5372 If MyComp.DesignerState*[dsStored]<>[] Then
5373 Begin
5374 p1:=Pointer(PropertyNameTable);
5375
5376 p2:=Pointer(MyComp); //Object address
5377 If p2<>Nil Then
5378 Begin
5379 //Write properties Of the Class
5380 B:=1;
5381 If Stream.Write(B,1)=0 Then Goto ex;
5382
5383 tt:=NameTableAdd(Namep); //Name Of the Property
5384 If Stream.Write(tt,4)=0 Then Goto ex;
5385
5386 {Type Info For the Property}
5387 B:=Ord(SCUClass);
5388 If Stream.Write(B,1)=0 Then Goto ex;
5389
5390
5391 p2:=Pointer(p2^); //VMT address
5392 Inc(p2,4);
5393 p2:=Pointer(p2^); //Class Info
5394 Inc(p2,4);
5395 pParent1:=Pointer(p2^); //parent Class VMT Or Nil
5396 Inc(p2,8);
5397 p2:=Pointer(p2^); //Property Info
5398 If Not WriteProperties(Stream,p2,MyComp,pParent1) Then Goto ex;
5399 PropertyNameTable:=Pointer(p1);
5400 End;
5401 End;
5402 End;
5403
5404 //dont Write TBitmap here (Extra Data In BitButton Or Picture)
5405
5406 Goto L; //don't Write Class/ClassVar
5407 End
5408 Else
5409 Begin
5410 //only Write If Value Is different from Default Value
5411 If Typ=PropType_String Then ValueLen:=(Value^ And 255)+1; //String
5412 If ValueLen>TypLen Then ValueLen:=TypLen;
5413
5414 If CompareResMem(Value^,ReferenceValue^,ValueLen) Then Goto L;
5415 End;
5416lll1:
5417 //the Value differs from the Default Value And MUST be written
5418
5419 If Typ=PropType_Link Then B:=2
5420 Else B:=1;
5421 If Stream.Write(B,1)=0 Then Goto ex;
5422
5423 tt:=NameTableAdd(Namep); //Name Of the Property
5424 If Stream.Write(tt,4)=0 Then Goto ex;
5425
5426 tt:=0;
5427 Case Typ Of
5428 PropType_Unsigned:B:=Ord(SCUUnsignedTypes[ValueLen]);
5429 PropType_Signed:B:=Ord(SCUSignedTypes[ValueLen]);
5430 PropType_Float:B:=Ord(SCUFloatTypes[ValueLen]);
5431 PropType_Set:
5432 Begin
5433 If ValueLen=4 Then B:=Ord(SCUSet4)
5434 Else B:=Ord(SCUSet32);
5435 End;
5436 PropType_CString:B:=Ord(SCUCString);
5437 PropType_Record:
5438 Begin
5439 B:=Ord(SCURecord);
5440 If Stream.Write(B,1)=0 Then Goto ex;
5441 tt:=ValueLen;
5442 If Stream.Write(tt,4)=0 Then Goto ex;
5443 End;
5444 PropType_Class:B:=Ord(SCUClass);
5445 PropType_String:B:=Ord(SCUString);
5446 PropType_Enum:B:=Ord(SCUEnum);
5447 PropType_Boolean:B:=Ord(SCUBooleanTypes[ValueLen]);
5448 PropType_Char:B:=Ord(SCUChar);
5449 PropType_ClassVar:B:=Ord(SCUClassVar);
5450 PropType_ProcVar:B:=Ord(SCUProcVar);
5451 PropType_FuncVar:B:=Ord(SCUFuncVar);
5452 PropType_Link:B:=Ord(SCULink);
5453 Else
5454 Begin
5455 B:=Ord(SCUBinary);
5456 If Stream.Write(B,1)=0 Then Goto ex;
5457 tt:=ValueLen;
5458 If Stream.Write(tt,4)=0 Then Goto ex;
5459 End;
5460 End;
5461
5462 If tt=0 Then If Stream.Write(B,1)=0 Then Goto ex; //Not For records
5463
5464 Case Typ Of
5465 PropType_ProcVar,PropType_FuncVar: //Events
5466 Begin
5467 //Owner Type Name
5468 If AOwner.FName=Nil Then AOwner.Name:=AOwner.ClassName;
5469 tt:=NameTableAdd(AOwner.FName);
5470 If Stream.Write(tt,4)=0 Then Goto ex;
5471
5472 //method Name
5473 tt:=NameTableAdd(Methods^.Name);
5474 If Stream.Write(tt,4)=0 Then Goto ex;
5475
5476 //Property Name
5477 tt:=NameTableAdd(Namep);
5478 If Stream.Write(tt,4)=0 Then Goto ex;
5479 End;
5480 PropType_Link: //Link
5481 Begin
5482 //Link field Name
5483 If MyComp=Nil Then Goto ex;
5484
5485 If MyComp.FName=Nil Then MyComp.Name:=MyComp.ClassName;
5486 tt:=NameTableAdd(MyComp.FName);
5487 If Stream.Write(tt,4)=0 Then Goto ex;
5488 End;
5489 Else //others
5490 Begin
5491 If Typ=PropType_String Then ValueLen:=(Value^ And 255)+1; //String
5492 If ValueLen>TypLen Then ValueLen:=TypLen;
5493 If Stream.Write(Value^,ValueLen)=0 Then Goto ex;
5494 End;
5495 End; {Case}
5496 End
5497 Else Goto ex; //Some Error
5498L:
5499 Result:=True;
5500ex:
5501 FreeMem(Value,TypLen);
5502 FreeMem(ReferenceValue,TypLen);
5503End;
5504
5505
5506
5507Function WriteProperties(Stream:TMemoryStream;p1:Pointer;Objekt:TComponent;
5508 pParent:Pointer):Boolean;
5509Var Namep,P,pp,p2:^LongInt;
5510 B:Byte;
5511 NameLen:LongInt;
5512 len,OldPos,EndPos:LongInt;
5513 ReferenceObjekt:TComponent;
5514 ObjektClass:TComponentClass;
5515 Scope:Byte;
5516Label L,ex;
5517Begin
5518 Result:=False;
5519 P:=p1;
5520
5521 ObjektClass:=Objekt.ClassType;
5522 InsideWriteSCUAdr^:=True;
5523 ReferenceObjekt:=Nil;
5524 Try
5525 ReferenceObjekt:=ObjektClass.Create({Objekt.FOwner}Nil);
5526 Include(ReferenceObjekt.ComponentState, csWriting);
5527 InsideWriteSCUAdr^:=False;
5528
5529 OldPos:=Stream.Position;
5530 len:=0; //patched later
5531 If Stream.Write(len,4)=0 Then Goto ex;
5532 Inc(P,4); //onto Property Name Table
5533 PropertyNameTable:=Pointer(P^);
5534 Inc(P,4); //onto First Name
5535L:
5536 NameLen:=P^ And 255;
5537 Namep:=Pointer(P);
5538
5539 If NameLen<>0 Then
5540 Begin
5541 Inc(P,NameLen+1); //overread Name
5542 Scope:=P^ And 255;
5543 Inc(P);
5544 If Scope And 16=0 Then //Not stored
5545 Begin
5546 Inc(P,4);
5547 Goto L;
5548 End;
5549
5550 //Property Is stored, Find out If we need To Write the Value Of it To the SCU Stream
5551 p2:=Pointer(P^); //Property Type And access Info
5552 If p2<>Nil Then
5553 If Not WritePropertyValues(Stream,p2,Objekt,Namep,ReferenceObjekt) Then Goto ex; //Some Error
5554 Inc(P,4); //Until All properties written
5555 Goto L;
5556 End;
5557
5558 If pParent<>Nil Then
5559 Begin
5560 pp:=pParent; //parent VMT Info
5561 Inc(pp,4);
5562 pp:=Pointer(pp^); //ClassInfo
5563 Inc(pp,4);
5564 pParent:=Pointer(pp^); //parent Class VMT Or Nil
5565 Inc(pp,8);
5566 pp:=Pointer(pp^); //Property Pointer
5567 P:=pp;
5568 p1:=P;
5569 Inc(P,4); //onto Property Name Table
5570 PropertyNameTable:=Pointer(P^);
5571 Inc(P,4); //onto First Name
5572 Goto L; //Write parent properties
5573 End;
5574
5575 B:=0;
5576 If Stream.Write(B,1)=0 Then Goto ex;
5577
5578 EndPos:=Stream.Position;
5579 len:=EndPos-OldPos;
5580 Stream.Position:=OldPos;
5581 If Stream.Write(len,4)=0 Then Goto ex;
5582 Stream.Position:=EndPos;
5583
5584 Result:=True;
5585ex:
5586 Finally
5587 If ReferenceObjekt<>Nil Then ReferenceObjekt.Destroy;
5588 InsideWriteSCUAdr^:=False;
5589 End;
5590End;
5591
5592Function WriteNameTable(Stream:TMemoryStream):Boolean;
5593Var T:LongInt;
5594 pp:PString;
5595Begin
5596 Result:=False;
5597
5598 For T:=0 To NameTable.Count-1 Do
5599 Begin
5600 pp:=NameTable.Items[T];
5601 If Stream.Write(pp^,Length(pp^)+1)=0 Then Exit;
5602 End;
5603
5604 NameTable.Destroy; {!!}
5605 Result:=True;
5606End;
5607
5608
5609Function WriteObjectComponents(Stream:TMemoryStream;ResStream:TResourceStream;
5610 Objekt:TComponent):Boolean;
5611Var Count:LongInt;
5612 PatchStreamPos:LongInt;
5613 CurStreamPos:LongInt;
5614Begin
5615 Result := False;
5616
5617 Objekt.SCUStream := Stream;
5618 Objekt.SCUResStream := ResStream;
5619 PatchStreamPos := Stream.Position;
5620
5621 Count := 0;
5622 If Stream.Write(Count,4) = 0 Then Exit; {Write dummy, patch it later}
5623 Objekt.FWriteComponentCount := 0;
5624 Objekt.GetChildren(Objekt.WriteComponent);
5625 Count := Objekt.FWriteComponentCount;
5626
5627 Objekt.SCUStream := Nil;
5628 Objekt.SCUResStream := Nil;
5629
5630 CurStreamPos := Stream.Position;
5631 Stream.Position := PatchStreamPos;
5632 If Stream.Write(Count,4) = 0 Then Exit;
5633 Stream.Position := CurStreamPos;
5634
5635 Result := Not Objekt.SCUWriteError;
5636End;
5637
5638
5639{Write SCU information Of the Child Component}
5640Procedure TComponent.WriteComponent(Child:TComponent);
5641Const Zero:LongInt=0;
5642Var pp,pp1,pParent1:^LongInt;
5643 tt:LongInt;
5644 B:Byte;
5645 Ok:Boolean;
5646 err:String[40];
5647Label ex;
5648Begin
5649 If csReferenceControl In Child.ComponentState Then
5650 Begin //Write the referenced Component before Self
5651 If Child.FReference <> Nil Then WriteComponent(Child.FReference);
5652 End;
5653
5654 Ok:=False;
5655 err:='Stream write error';
5656 Try
5657 SCUWriteError := True;
5658 If SCUStream = Nil Then Goto ex;
5659 If SCUResStream = Nil Then Goto ex;
5660
5661 pp:=Pointer(Child);
5662 pp:=Pointer(pp^); //VMT Info
5663
5664 Inc(pp,4);
5665 pp:=Pointer(pp^); //ClassInfo
5666 pp1:=pp;
5667 Inc(pp,4);
5668 pParent1:=Pointer(pp^); //parent Class VMT Or Nil
5669 Inc(pp,8);
5670 pp:=Pointer(pp^); //Property Pointer
5671
5672 //Write Inspector Class Name
5673 Inc(pp1,16); //onto ClassName
5674 tt:=NameTableAdd(Pointer(pp1));
5675 If SCUStream.Write(tt,4)=0 Then Goto ex;
5676
5677 //Write runtime Class Name
5678 If Child.FTypeName=Nil Then
5679 Begin
5680 B:=0; //runtime And Inspector Type Name are identical
5681 If SCUStream.Write(B,1)=0 Then Goto ex;
5682 End
5683 Else
5684 Begin
5685 B:=1; //runtime Name Is different from Inspector Name
5686 If SCUStream.Write(B,1)=0 Then Goto ex;
5687 tt:=NameTableAdd(Child.FTypeName);
5688 If SCUStream.Write(tt,4)=0 Then Goto ex;
5689 End;
5690
5691 If Not WriteProperties(SCUStream,pp,Child,pParent1) Then
5692 Begin
5693 err:='WriteProperties error';
5694 Goto ex; //Some Error
5695 End;
5696
5697 //Write Components that are owned by the Object
5698 If Not WriteObjectComponents(SCUStream,SCUResStream,Child) Then
5699 Begin
5700 err:='WriteObjectComponents error';
5701 Goto ex;
5702 End;
5703
5704 //Write Extra Data For that Component
5705 If Not Child.WriteSCUResource(SCUResStream) Then
5706 Begin
5707 err:='WriteSCUResource error';
5708 Goto ex;
5709 End;
5710 If SCUStream.Write(Zero,4)=0 Then Goto ex; {no more resources}
5711
5712 SCUWriteError := False;
5713
5714 Inc(FWriteComponentCount);
5715
5716 Ok:=True;
5717 Except
5718 err:=err+' due to exception';
5719 End;
5720ex:
5721 If Not Ok Then
5722 Begin
5723 Raise ESCUError.Create('SCU write error for '+Child.ClassName+': '+err);
5724 End;
5725End;
5726
5727
5728Procedure TComponent.WriteToStream(SCUStream:TStream);
5729Const Zero:LongInt=0;
5730Var Stream:TMemoryStream;
5731 ResourceStream:TResourceStream;
5732 P,p1,pParent:^LongInt;
5733 FileDesc:TSCUFileFormat;
5734Begin
5735 Stream.Create;
5736 Stream.Capacity:=32768;
5737
5738 ResourceStream.Create;
5739 ResourceStream.Capacity:=32768;
5740 ResourceStream.SCUStream:=Stream;
5741 ResourceStream.FHeaderPos:=8; {Initial Resource Header}
5742
5743 NameTable.Create; {wo zerst”rt??}
5744
5745 FillChar(FileDesc,SizeOf(TSCUFileFormat),0);
5746 FileDesc.Version:=SCUVersion;
5747 If Stream.Write(FileDesc,SizeOf(TSCUFileFormat))=0 Then //SCU Header
5748 Raise ESCUError.Create('Stream write error');
5749
5750 FileDesc.ObjectOffset:=Stream.Position;
5751 FileDesc.ObjectCount:=1; //Count Of Objects
5752
5753 P:=Pointer(Self);
5754 P:=Pointer(P^); //VMT Info
5755
5756 Inc(P,4);
5757 P:=Pointer(P^); //ClassInfo
5758 p1:=P;
5759 Inc(P,4);
5760 pParent:=Pointer(P^); //parent Class VMT Or Nil
5761 Inc(P,8);
5762 P:=Pointer(P^); //Property Pointer
5763
5764 Inc(p1,16); //onto ClassName
5765
5766 If Not WriteProperties(Stream,P,Self,pParent) Then
5767 Raise ESCUError.Create('WriteProperties failed');
5768
5769 //Write Components that are owned by the Object
5770 If Not WriteObjectComponents(Stream,ResourceStream,Self) Then
5771 Raise ESCUError.Create('WriteObjectComponents failed');
5772
5773 If Not WriteSCUResource(ResourceStream) Then
5774 Raise ESCUError.Create('WriteSCUResource failed');
5775 If Stream.Write(Zero,4)=0 Then
5776 Raise ESCUError.Create('Stream Write Error'); {no more resources}
5777
5778 FileDesc.ObjectLen:=Stream.Position-FileDesc.ObjectOffset;
5779
5780 //patch Name Table
5781 FileDesc.NameTableOffset:=Stream.Position;
5782 If Not WriteNameTable(Stream) Then
5783 Raise ESCUError.Create('Stream write error');
5784 FileDesc.NameTableLen:=Stream.Position-FileDesc.NameTableOffset;
5785
5786 FileDesc.ResourceOffset:=Stream.Position;
5787 {Write Resource information}
5788 If Not ResourceStream.WriteResourcesToStream(Stream) Then
5789 Raise ESCUError.Create('Stream write error');
5790 ResourceStream.Destroy;
5791 FileDesc.ResourceLen:=Stream.Position-FileDesc.ResourceOffset;
5792
5793 Stream.Position:=0; //patch Header
5794 If Stream.Write(FileDesc,SizeOf(TSCUFileFormat))=0 Then
5795 Raise ESCUError.Create('Stream write error');
5796
5797 //Copy Stream
5798 SCUStream.WriteBuffer(Stream.FBuffer^,Stream.FSize);
5799 Stream.Destroy;
5800End;
5801
5802Procedure TComponent.ReadSCU(Data:Pointer);
5803Var
5804 ClassPointer,P,p1:^LongWord;
5805 dummy:PSCUFileFormat;
5806 NameTable:^LongWord;
5807 ResourceTable:^LongWord;
5808 ActComponentClass:TComponentClass;
5809 S,s1:String;
5810 ObjectCount:LongInt;
5811 ps:^String;
5812 OldInsideDesigner:Boolean;
5813 LanguageInfo:^LongWord;
5814 MessageInfo:^LongWord;
5815 Flags:Byte;
5816 T:LongInt;
5817 CurrentLanguage:String;
5818 LangItem:PLanguageItem;
5819 Msgs:PLanguageMessages;
5820 MsgLen:LongWord;
5821
5822 Procedure ReadLanguage(Var Components:PLanguageComponent);
5823 Var
5824 LangComp:PLanguageComponent;
5825 ps:^String;
5826 Begin
5827 Components:=Nil;
5828
5829 While (LanguageInfo^ And 255)<>0 Do //Read All Components entries
5830 Begin
5831 Inc(LanguageInfo); //skip 1
5832
5833 If Components=Nil Then
5834 Begin
5835 New(Components);
5836 LangComp:=Components;
5837 End
5838 Else
5839 Begin
5840 LangComp:=Components;
5841 While LangComp^.Next<>Nil Do LangComp:=LangComp^.Next;
5842 New(LangComp^.Next);
5843 LangComp:=LangComp^.Next;
5844 End;
5845 LangComp^.Next:=Nil;
5846
5847 ps:=Pointer(LanguageInfo);
5848 GetMem(LangComp^.Name,Length(ps^)+1);
5849 LangComp^.Name^:=ps^;
5850 Inc(LanguageInfo,Length(ps^)+1);
5851
5852 LangComp^.ValueTyp:=LanguageInfo^ And 255;
5853 Inc(LanguageInfo);
5854
5855 LangComp^.ValueLen:=LanguageInfo^;
5856 Inc(LanguageInfo,4);
5857
5858 GetMem(LangComp^.Value,LangComp^.ValueLen);
5859 Move(LanguageInfo^,LangComp^.Value^,LangComp^.ValueLen);
5860 Inc(LanguageInfo,LangComp^.ValueLen);
5861
5862 LangComp^.ControlLeft:=LanguageInfo^;
5863 Inc(LanguageInfo,4);
5864 LangComp^.ControlBottom:=LanguageInfo^;
5865 Inc(LanguageInfo,4);
5866 LangComp^.ControlWidth:=LanguageInfo^;
5867 Inc(LanguageInfo,4);
5868 LangComp^.ControlHeight:=LanguageInfo^;
5869 Inc(LanguageInfo,4);
5870 End;
5871 Inc(LanguageInfo); //skip 0
5872 End;
5873
5874Label loadit,Next,skip;
5875Begin
5876 OldInsideDesigner:=InsideDesigner;
5877 dummy:=Data;
5878 PropertyLinks:=Nil;
5879 MessageInfo:=NIL;
5880 LanguageInfo:=NIL;
5881
5882 While dummy<>Nil Do
5883 Begin
5884 NameTable:=Pointer(dummy);
5885 Inc(NameTable,dummy^.NameTableOffset);
5886 ResourceTable:=Pointer(dummy);
5887 Inc(ResourceTable,dummy^.ResourceOffset);
5888
5889 P:=Pointer(dummy);
5890 Inc(P,dummy^.ObjectOffset);
5891
5892 S:=ClassName;
5893 UpcaseStr(S);
5894 If ((((InsideDesigner)Or(InsideLanguageDesigner)))And(S='TFORMEDITOR')) Then
5895 Begin
5896 //always Use the Class entry defined by dummy^.UseEntry !
5897 p1:=Pointer(dummy);
5898 Inc(p1,SizeOf(TSCUFileFormat));
5899 ObjectCount:=0;
5900 LanguageInfo:=Nil;
5901 MessageInfo:=Nil;
5902 While ObjectCount<>dummy^.UseEntry+1 Do
5903 Begin
5904 Flags:=p1^ And 255; //1- auto Create, 2- Language Info avail
5905 Inc(p1); //skip flag
5906 Inc(p1,(p1^ And 255)+1); //skip Form Name
5907 Inc(p1,(p1^ And 255)+1); //skip Form Unit Name
5908 Inc(p1,(p1^ And 255)+1); //skip Form TypeName
5909 //If Message information Is available For This Form (only For First) remember And skip it !
5910 If (Flags And 8)<>0 Then
5911 Begin
5912 MessageInfo:=Pointer(p1);
5913 Inc(p1,p1^);
5914 End;
5915 //If Language information Is available For This Form, remember And skip
5916 LanguageInfo:=Pointer(p1);
5917 If Flags And 2<>0 Then Inc(p1,p1^); //skip Language Info
5918 Inc(ObjectCount);
5919 End;
5920
5921 If (Flags And 2)=0 Then LanguageInfo:=Nil; //no languages avail
5922 If (Flags And 4)<>0 Then LanguageInfo:=Nil; //locked !!
5923
5924 ObjectCount:=0;
5925 While ObjectCount<>dummy^.UseEntry Do
5926 Begin
5927 Inc(P,{4+}P^); //overread This entry
5928 Inc(ObjectCount);
5929 End;
5930
5931 ClassPointer:=P;
5932 Inc(P,4); //Set ON Inspector Class Name
5933 Inc(P,(P^ And 255)+1); //overread Inspector Name
5934 Inc(P,(P^ And 255)+1); //overread runtime Class Name
5935 ps:=Pointer(P); //Unit Name For This Form
5936 AssignStr(FUnitName,ps^);
5937 Goto loadit;
5938 End
5939 Else
5940 Begin
5941 //don't Read any Classes when inside designer !
5942 //If (InsideDesigner And (Not InsideCompLib)) Then Exit;
5943 If InsideCompLib Then InsideDesigner:=False;
5944
5945 //Search For Class named S inside area P With dummy^.ObjectCount
5946 //entries And Set ClassPointer To Object Data Start
5947 //Use also ClassUnit For Reference
5948 ClassPointer:=SearchClassSCU(P,S,dummy^.ObjectCount,ClassUnit);
5949 If ClassPointer=Nil Then Goto Next; //no Class found
5950
5951 //look If Language Info Is avail
5952 p1:=Pointer(dummy);
5953 Inc(p1,SizeOf(TSCUFileFormat));
5954 For T:=1 To dummy^.ObjectCount Do
5955 Begin
5956 Flags:=p1^ And 255;
5957 Inc(p1); //skip flag
5958 Inc(p1,(p1^ And 255)+1); //skip Form Name
5959 Inc(p1,(p1^ And 255)+1); //skip Form Unit Name
5960 If (Flags And 2)<>0 Then //Language Info avail ???
5961 Begin
5962 ps:=Pointer(p1);
5963 Inc(p1,(p1^ And 255)+1); //skip Form Type Name
5964
5965 //If Message information Is available For This Form (only For First) skip it !
5966 If (Flags And 8)<>0 Then Inc(p1,p1^);
5967
5968 s1:=ps^;
5969 UpcaseStr(s1);
5970 If S=s1 Then //found !
5971 Begin
5972 LanguageInfo:=Pointer(p1);
5973 If (Flags And 4)<>0 Then LanguageInfo:=Nil; //locked !!
5974 Goto loadit;
5975 End
5976 Else Inc(p1,p1^); //only skip Info
5977 End
5978 Else
5979 Begin
5980 Inc(p1,(p1^ And 255)+1); //skip Form Type Name
5981 //If Message information Is available For This Form (only For First) skip it !
5982 If (Flags And 8)<>0 Then Inc(p1,p1^);
5983 End;
5984 End;
5985 LanguageInfo:=Nil; //Not found
5986loadit:
5987 Inc(ClassPointer,4); //Set ON Inspector Class Name
5988 Inc(ClassPointer,(ClassPointer^ And 255)+1); //overread Inspector Name
5989 Inc(ClassPointer,(ClassPointer^ And 255)+1); //overread runtime Class Name
5990 Inc(ClassPointer,(ClassPointer^ And 255)+1); //overread Unit Name
5991
5992 ActComponentClass:=ClassType;
5993 RegisterClasses([ActComponentClass]); //Form registrieren
5994 If ((InsideDesigner)Or(InsideLanguageDesigner)) Then
5995 Begin
5996 FMethods:=Nil; //no Methods defined
5997 End;
5998
5999 LastSCUForm:=Self;
6000
6001 LoadingFromSCU(Nil);
6002
6003 //Build Message lists
6004 If MessageInfo<>Nil Then
6005 Begin
6006 Inc(MessageInfo,4); //skip Size
6007
6008 ps:=Pointer(MessageInfo);
6009 AppLanguage:=ps^;
6010 Inc(MessageInfo,Length(ps^)+1);
6011
6012 ps:=Pointer(MessageInfo);
6013 While Length(ps^)<>0 Do
6014 Begin
6015
6016 //look If the Language Is installed, skip If True
6017 If LanguageMessages=Nil Then
6018 Begin
6019 New(LanguageMessages);
6020 Msgs:=LanguageMessages;
6021 End
6022 Else
6023 Begin
6024 Msgs:=LanguageMessages;
6025 While Msgs^.Next<>Nil Do
6026 Begin
6027 If Msgs^.Name^=ps^ Then
6028 Begin
6029 Inc(MessageInfo,Length(ps^));
6030 MsgLen:=MessageInfo^;
6031 Inc(MessageInfo,4);
6032 Inc(MessageInfo,MsgLen);
6033 Goto skip;
6034 End;
6035 Msgs:=Msgs^.Next;
6036 End;
6037 If Msgs^.Name^=ps^ Then
6038 Begin
6039 Inc(MessageInfo,Length(ps^)+1);
6040 MsgLen:=MessageInfo^;
6041 Inc(MessageInfo,4);
6042 Inc(MessageInfo,MsgLen);
6043 Goto skip;
6044 End;
6045 New(Msgs^.Next);
6046 Msgs:=Msgs^.Next;
6047 End;
6048
6049 GetMem(Msgs^.Name,Length(ps^)+1);
6050 Msgs^.Name^:=ps^;
6051 Inc(MessageInfo,Length(ps^)+1);
6052 Msgs^.StringTableLen:=MessageInfo^;
6053 Inc(MessageInfo,4);
6054 GetMem(Msgs^.StringTable,Msgs^.StringTableLen);
6055 Move(MessageInfo^,Msgs^.StringTable^,Msgs^.StringTableLen);
6056 Inc(MessageInfo,Msgs^.StringTableLen);
6057skip:
6058 ps:=Pointer(MessageInfo);
6059 End;
6060 End;
6061
6062 //Build Language lists
6063 If LanguageInfo<>Nil Then
6064 Begin
6065 Inc(LanguageInfo,4); //skip Size
6066 GetMem(FLanguages,SizeOf(TLanguageInfo));
6067 ps:=Pointer(LanguageInfo);
6068 CurrentLanguage:=ps^; //To determine Language !
6069 Inc(LanguageInfo,Length(CurrentLanguage)+1);
6070
6071 While (LanguageInfo^ And 255)<>0 Do //Read All entries
6072 Begin
6073 Inc(LanguageInfo); //skip 1
6074
6075 If PLanguageInfo(FLanguages)^.Items=Nil Then
6076 Begin
6077 New(LangItem);
6078 PLanguageInfo(FLanguages)^.Items:=LangItem;
6079 End
6080 Else
6081 Begin
6082 LangItem:=PLanguageInfo(FLanguages)^.Items;
6083 While LangItem^.Next<>Nil Do LangItem:=LangItem^.Next;
6084 New(LangItem^.Next);
6085 LangItem:=LangItem^.Next;
6086 End;
6087
6088 LangItem^.Next:=Nil;
6089
6090 ps:=Pointer(LanguageInfo);
6091 GetMem(LangItem^.Name,Length(ps^)+1);
6092 LangItem^.Name^:=ps^;
6093 Inc(LanguageInfo,Length(ps^)+1);
6094
6095 ReadLanguage(LangItem^.Components);
6096 ReadLanguage(LangItem^.Menus);
6097 ReadLanguage(LangItem^.StringTables);
6098 End; //While
6099 Inc(LanguageInfo); //skip 0
6100
6101 If PLanguageInfo(FLanguages)^.Items=Nil Then //no Items
6102 Begin
6103 FreeMem(FLanguages,SizeOf(TLanguageInfo));
6104 FLanguages:=Nil;
6105 End
6106 Else
6107 Begin
6108 //Set Current Language into Form^.LanguageInfo
6109 LangItem:=PLanguageInfo(FLanguages)^.Items;
6110 While LangItem<>Nil Do
6111 Begin
6112 If LangItem^.Name^=CurrentLanguage Then //found
6113 Begin
6114 PLanguageInfo(FLanguages)^.CurrentLanguageName:=LangItem^.Name;
6115 PLanguageInfo(FLanguages)^.CurrentLanguageComponents:=LangItem^.Components;
6116 PLanguageInfo(FLanguages)^.CurrentLanguageMenus:=LangItem^.Menus;
6117 PLanguageInfo(FLanguages)^.CurrentLanguageStringTables:=LangItem^.StringTables;
6118 break;
6119 End;
6120 LangItem:=LangItem^.Next;
6121 End;
6122
6123 If PLanguageInfo(FLanguages)^.CurrentLanguageName=Nil Then
6124 Begin
6125 //Not found - Use First available Language
6126 LangItem:=PLanguageInfo(FLanguages)^.Items;
6127 PLanguageInfo(FLanguages)^.CurrentLanguageName:=LangItem^.Name;
6128 PLanguageInfo(FLanguages)^.CurrentLanguageComponents:=LangItem^.Components;
6129 PLanguageInfo(FLanguages)^.CurrentLanguageMenus:=LangItem^.Menus;
6130 PLanguageInfo(FLanguages)^.CurrentLanguageStringTables:=LangItem^.StringTables;
6131 End;
6132 End;
6133 End;
6134
6135 If Not ReadPropertiesSCU(Self,NameTable,ResourceTable,ClassPointer) Then
6136 Begin
6137 InsideDesigner:=OldInsideDesigner;
6138 Raise ESCUError.Create('ReadPropertiesSCU error');
6139 End;
6140
6141 SetDesigning(InsideDesigner Or InsideLanguageDesigner);
6142
6143 //check For Child Components
6144 If Not ReadComponentsSCU(NameTable,ResourceTable,ClassPointer) Then
6145 Begin
6146 InsideDesigner:=OldInsideDesigner;
6147 Raise ESCUError.Create('ReadComponentsSCU error');
6148 End;
6149
6150 //links For the Form
6151 HandlePropertyLinks(Self);
6152
6153 ReadResourceSCU(ResourceTable,ClassPointer);
6154
6155 If FLanguages<>Nil Then
6156 If PLanguageInfo(FLanguages)^.CurrentLanguageName<>Nil Then
6157 SetLanguage(Self,PLanguageInfo(FLanguages)^.CurrentLanguageName^);
6158
6159 //If there's only the Default Language Left, Erase it !
6160 If FLanguages<>Nil Then
6161 If PLanguageInfo(FLanguages)^.Items<>Nil Then
6162 If PLanguageInfo(FLanguages)^.Items^.Next=Nil Then
6163 If PLanguageInfo(FLanguages)^.Items^.Name^='Default' Then
6164 Begin
6165 FreeLanguage(PLanguageInfo(FLanguages)^.Items^.Components);
6166 FreeLanguage(PLanguageInfo(FLanguages)^.Items^.Menus);
6167 FreeLanguage(PLanguageInfo(FLanguages)^.Items^.StringTables);
6168 FreeMem(PLanguageInfo(FLanguages)^.Items^.Name,Length(PLanguageInfo(FLanguages)^.Items^.Name^)+1);
6169 Dispose(PLanguageInfo(FLanguages)^.Items);
6170 FreeMem(FLanguages,SizeOf(TLanguageInfo));
6171 FLanguages:=Nil;
6172 End;
6173
6174 {For the Form}
6175 LoadedFromSCU(Nil);
6176 Loaded;
6177
6178 InsideDesigner:=OldInsideDesigner;
6179 Exit;
6180 End;
6181Next:
6182 dummy:=dummy^.NextEntry;
6183 End;
6184
6185 InsideDesigner:=OldInsideDesigner;
6186End;
6187
6188
6189Procedure TComponent.ReadFromStream(SCUStream:TStream);
6190Var
6191 ClassMem,ClassPointer:^LongWord;
6192 OldPos:LongInt;
6193 OldInsideDesigner:Boolean;
6194 FileDesc:TSCUFileFormat;
6195 len:LongInt;
6196 NameTable:^LongWord;
6197 ResourceTable:^LongWord;
6198Begin
6199 Try
6200 ClassPointer:=Nil;
6201 OldInsideDesigner:=InsideDesigner;
6202 If InsideCompLib Then InsideDesigner:=False;
6203
6204 OldPos:=SCUStream.Position;
6205 SCUStream.ReadBuffer(FileDesc,SizeOf(FileDesc));
6206 SCUStream.Position:=OldPos;
6207
6208 len:=SizeOf(FileDesc)+FileDesc.ObjectLen+FileDesc.NameTableLen+FileDesc.ResourceLen;
6209 GetMem(ClassPointer,len);
6210 ClassMem:=ClassPointer;
6211 SCUStream.ReadBuffer(ClassPointer^,len);
6212
6213 NameTable:=Pointer(ClassPointer);
6214 Inc(NameTable,FileDesc.NameTableOffset);
6215 ResourceTable:=Pointer(ClassPointer);
6216 Inc(ResourceTable,FileDesc.ResourceOffset);
6217 Inc(ClassPointer,FileDesc.ObjectOffset);
6218
6219 LastSCUForm:=Owner;
6220 SetDesigning(InsideDesigner Or InsideLanguageDesigner);
6221 LoadingFromSCU(LastSCUForm);
6222
6223 If Not ReadPropertiesSCU(LastSCUForm,NameTable,ResourceTable,ClassPointer) Then
6224 Raise ESCUError.Create('SCU error');
6225 If Not ReadComponentsSCU(NameTable,ResourceTable,ClassPointer) Then
6226 Raise ESCUError.Create('SCU error');
6227 ReadResourceSCU(ResourceTable,ClassPointer);
6228
6229 LoadedFromSCU(LastSCUForm);
6230 Finally
6231 InsideDesigner:=OldInsideDesigner;
6232 If ClassMem<>Nil Then FreeMem(ClassMem,len);
6233 End;
6234End;
6235
6236
6237{$HINTS OFF}
6238Procedure TComponent.GetChildren(Proc:TGetChildProc);
6239Begin
6240End;
6241{$HINTS ON}
6242
6243
6244Function TComponent.HasParent:Boolean;
6245Begin
6246 Result := False;
6247End;
6248
6249Function WritePropertiesToStream(FormList:TList):TMemoryStream;
6250Const Zero:LongInt=0;
6251 bt:Byte=1;
6252 bf:Byte=0;
6253Var P,p1:^LongInt;
6254 pParent:^LongInt;
6255 S:String;
6256 tt,tt1,Pos1:LongInt;
6257 FormItem:PFormListItem;
6258 Stream:TMemoryStream;
6259 ResourceStream:TResourceStream;
6260 FileDesc:TSCUFileFormat;
6261 C:TComponent;
6262 D,N,E:String;
6263 bb:Byte;
6264 LangItem:PLanguageItem;
6265 LangPos,LangTemp:LongInt;
6266 dummy:PLanguageMessages;
6267
6268 Function WriteLanguage(LangComp:PLanguageComponent):Boolean;
6269 Var Ende:Byte;
6270 Begin
6271 Result:=False;
6272 While LangComp<>Nil Do
6273 Begin
6274 If Stream.Write(bt,1)=0 Then Exit; //one more entry
6275 If Stream.Write(LangComp^.Name^,Length(LangComp^.Name^)+1)=0 Then Exit;
6276 If Stream.Write(LangComp^.ValueTyp,1)=0 Then Exit;
6277 If Stream.Write(LangComp^.ValueLen,4)=0 Then Exit;
6278 If Stream.Write(LangComp^.Value^,LangComp^.ValueLen)=0 Then Exit;
6279
6280 If Stream.Write(LangComp^.ControlLeft,4)=0 Then Exit;
6281 If Stream.Write(LangComp^.ControlBottom,4)=0 Then Exit;
6282 If Stream.Write(LangComp^.ControlWidth,4)=0 Then Exit;
6283 If Stream.Write(LangComp^.ControlHeight,4)=0 Then Exit;
6284
6285 LangComp:=LangComp^.Next;
6286 End;
6287
6288 Ende:=0;
6289 If Stream.Write(Ende,1)=0 Then Exit; //no more entries
6290 Result:=True;
6291 End;
6292
6293Label err;
6294Begin
6295 Result:=Nil; //Some Error
6296
6297 Stream.Create;
6298 Stream.Capacity:=32768;
6299
6300 ResourceStream.Create;
6301 ResourceStream.Capacity:=32768;
6302 ResourceStream.SCUStream:=Stream;
6303 ResourceStream.FHeaderPos:=8; {Initial Resource Header}
6304
6305 NameTable.Create;
6306
6307 FillChar(FileDesc,SizeOf(TSCUFileFormat),0);
6308 FileDesc.Version:=SCUVersion;
6309 If Stream.Write(FileDesc,SizeOf(TSCUFileFormat))=0 Then //SCU Header
6310 Begin
6311err:
6312 Stream.Destroy;
6313 ResourceStream.Destroy;
6314 Result:=Nil;
6315 Exit; //Some Error
6316 End;
6317
6318 Try
6319 For tt:=0 To FormList.Count-1 Do
6320 Begin
6321 FormItem:=FormList.Items[tt];
6322 C:=Pointer(FormItem^.Form);
6323 If C = Nil Then Goto err; {need Form}
6324
6325 bb:=0;
6326
6327 If C.DesignerState*[dsAutoCreate]<>[] Then bb:=bb Or 1; //auto-created Form
6328 If C.FLanguages<>Nil Then bb:=bb Or 2; //Multi Language
6329 //!!!!!!!!!! 4 Is reserved For locking Language !!!!!!!!!!!!!!!!!!!
6330
6331 //note: Messages are global To an Application, Not To A Form !!!!
6332 If ((tt=0)And(LanguageMessages<>Nil)) Then bb:=bb Or 8; //Messages avail
6333
6334 If Stream.Write(bb,1)=0 Then Goto err;
6335
6336 S:=FormItem^.FormName+#0;
6337 UpcaseStr(S);
6338 If Stream.Write(S,Length(S)+1)=0 Then Goto err;
6339 S:=FormItem^.UnitName;
6340 FSplit(S,D,N,E);
6341 N:=N+#0;
6342 UpcaseStr(N);
6343 If Stream.Write(N,Length(N)+1)=0 Then Goto err;
6344 If FormItem^.FormName<>'' Then S:='T'+FormItem^.FormName
6345 Else S:=FormItem^.Form.ClassName;
6346 If Stream.Write(S,Length(S)+1)=0 Then Goto err; //runtime Class Name
6347
6348 //Language Messages are only evaluated by Application.Create by examining the SCU Pointer !!!
6349 If ((tt=0)And(LanguageMessages<>Nil)) Then
6350 Begin
6351 //Write Language Message information
6352 LangPos:=Stream.Position; //save Position
6353 If Stream.Write(LangPos,4)=0 Then Goto err; //Size: patched later
6354
6355 If Stream.Write(AppLanguage,Length(AppLanguage)+1)=0 Then Goto err;
6356
6357 dummy:=LanguageMessages;
6358 While dummy<>Nil Do
6359 Begin
6360 If Stream.Write(dummy^.Name^,Length(dummy^.Name^)+1)=0 Then Goto err;
6361 If Stream.Write(dummy^.StringTableLen,4)=0 Then Goto err;
6362 If dummy^.StringTableLen>0 Then
6363 If Stream.Write(dummy^.StringTable^,dummy^.StringTableLen)=0 Then Goto err;
6364 dummy:=dummy^.Next;
6365 End;
6366 If Stream.Write(bf,1)=0 Then Goto err; //no more entries
6367 LangTemp:=Stream.Position;
6368 Stream.Position:=LangPos; //patch Size
6369 LangPos:=LangTemp-LangPos;
6370 If Stream.Write(LangPos,4)=0 Then Goto err;
6371 Stream.Position:=LangTemp; //restore old Position
6372 End;
6373
6374 If C.FLanguages<>Nil Then
6375 Begin
6376 //Write Language information
6377 LangPos:=Stream.Position; //save Position
6378 If Stream.Write(LangPos,4)=0 Then Goto err; //Size: patched later
6379
6380 If PLanguageInfo(C.FLanguages)^.CurrentLanguageName<>Nil Then
6381 Begin
6382 If Stream.Write(PLanguageInfo(C.FLanguages)^.CurrentLanguageName^,
6383 Length(PLanguageInfo(C.FLanguages)^.CurrentLanguageName^)+1)=0 Then Goto err;
6384 End
6385 Else
6386 Begin
6387 S:='Default';
6388 If Stream.Write(S,Length(S)+1)=0 Then Goto err;
6389 End;
6390
6391 LangItem:=PLanguageInfo(C.FLanguages)^.Items;
6392
6393 While LangItem<>Nil Do
6394 Begin
6395 If Stream.Write(bt,1)=0 Then Goto err; //one more entry
6396 If Stream.Write(LangItem^.Name^,Length(LangItem^.Name^)+1)=0 Then Goto err;
6397
6398 If Not WriteLanguage(LangItem^.Components) Then Goto err;
6399 If Not WriteLanguage(LangItem^.Menus) Then Goto err;
6400 If Not WriteLanguage(LangItem^.StringTables) Then Goto err;
6401
6402 LangItem:=LangItem^.Next;
6403 End;
6404
6405 If Stream.Write(bf,1)=0 Then Goto err; //no more entries
6406
6407 LangTemp:=Stream.Position;
6408 Stream.Position:=LangPos; //patch Size
6409 LangPos:=LangTemp-LangPos;
6410 If Stream.Write(LangPos,4)=0 Then Goto err;
6411 Stream.Position:=LangTemp; //restore old Position
6412 End;
6413 End;
6414
6415 FileDesc.ObjectOffset:=Stream.Position;
6416 FileDesc.ObjectCount:=FormList.Count; //Count Of Objects
6417
6418 For tt:=0 To FormList.Count-1 Do
6419 Begin
6420 Pos1:=Stream.Position;
6421
6422 tt1:=0;
6423 If Stream.Write(tt1,4)=0 Then Goto err; //Length Of Object Info
6424 //- patched later
6425
6426 FormItem:=FormList.Items[tt];
6427 P:=Pointer(FormItem^.Form);
6428 P:=Pointer(P^); //VMT Info
6429
6430 Inc(P,4);
6431 P:=Pointer(P^); //ClassInfo
6432 p1:=P;
6433 Inc(P,4);
6434 pParent:=Pointer(P^); //parent Class VMT Or Nil
6435 Inc(P,8);
6436 P:=Pointer(P^); //Property Pointer
6437
6438 Inc(p1,16); //onto ClassName
6439 Move(p1^,S,(p1^ And 255)+1); //Inspector Class Name
6440 If Stream.Write(S,Length(S)+1)=0 Then Goto err; //Inspector Class Name
6441
6442 If FormItem^.FormName<>'' Then S:='T'+FormItem^.FormName
6443 Else S:=FormItem^.Form.ClassName;
6444 If Stream.Write(S,Length(S)+1)=0 Then Goto err; //runtime Class Name
6445 If Stream.Write(FormItem^.UnitName,Length(FormItem^.UnitName)+1)=0 Then Goto err;
6446
6447 If Not WriteProperties(Stream,P,TComponent(FormItem^.Form),pParent) Then Goto err;
6448
6449 //Write Components that are owned by the Object
6450 If Not WriteObjectComponents(Stream,ResourceStream,TComponent(FormItem^.Form)) Then Goto err;
6451
6452 If Not FormItem^.Form.WriteSCUResource(ResourceStream) Then Goto err;
6453 If Stream.Write(Zero,4)=0 Then Goto err; {no more resources}
6454
6455
6456 tt1:=Stream.Position;
6457 Stream.Position:=Pos1;
6458 Pos1:=tt1-Pos1;
6459 Stream.Write(Pos1,4); //patch len Of Object Info For This entry
6460 Stream.Position:=tt1;
6461 End; //For
6462
6463 FileDesc.ObjectLen:=Stream.Position-FileDesc.ObjectOffset;
6464
6465 //patch Name Table
6466 FileDesc.NameTableOffset:=Stream.Position;
6467 If Not WriteNameTable(Stream) Then Goto err;
6468 FileDesc.NameTableLen:=Stream.Position-FileDesc.NameTableOffset;
6469
6470 FileDesc.ResourceOffset:=Stream.Position;
6471 {Write Resource information}
6472 If Not ResourceStream.WriteResourcesToStream(Stream) Then Goto err;
6473 ResourceStream.Destroy;
6474 FileDesc.ResourceLen:=Stream.Position-FileDesc.ResourceOffset;
6475 {ab hier nichts mehr schreiben, sonst System.AddSCUData „ndern}
6476
6477 tt:=Stream.Position; //save Position
6478 Stream.Position:=0; //patch Header
6479 If Stream.Write(FileDesc,SizeOf(TSCUFileFormat))=0 Then Goto err;
6480 Stream.Position:=tt; //restore Position
6481 Except
6482 ON ex:Exception Do
6483 Begin
6484 ErrorBox2(ex.Message);
6485 Stream.Destroy;
6486 ResourceStream.Destroy;
6487 Stream:=Nil;
6488 End;
6489 End;
6490 Result:=Stream;
6491End;
6492
6493
6494Function WritePropertiesToFile(FileName:String;FormList:TList):Boolean;
6495Var Stream:TMemoryStream;
6496Begin
6497 Stream:=WritePropertiesToStream(FormList);
6498 If Stream=Nil Then
6499 Begin
6500 Result:=False;
6501 Exit;
6502 End;
6503
6504 Result:=True;
6505 Try
6506 Stream.SaveToFile(FileName);
6507 Except
6508 ON ex:Exception Do
6509 Begin
6510 ErrorBox2(ex.Message);
6511 Result:=False;
6512 End;
6513 End;
6514
6515 Stream.Destroy;
6516End;
6517
6518
6519
6520{
6521ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6522º º
6523º Speed-Pascal/2 Version 2.0 º
6524º º
6525º Speed-Pascal Component Classes (SPCC) º
6526º º
6527º This section: TStringItem Class Implementation º
6528º º
6529º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6530º º
6531ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6532}
6533
6534Procedure TStringSelectList.SetupComponent;
6535Begin
6536 Inherited SetupComponent;
6537 FList.Create;
6538 FList.sorted:=True;
6539 Include(ComponentState, csDetail);
6540End;
6541
6542Procedure TStringSelectList.SetStringItem(NewValue:String);
6543Begin
6544 FSelected:=NewValue;
6545End;
6546
6547Destructor TStringSelectList.Destroy;
6548Begin
6549 FList.Destroy;
6550 FList := Nil;
6551 Inherited Destroy;
6552End;
6553
6554Function TStringSelectList.GetItems:TStringList;
6555Begin
6556 Result:=FList;
6557End;
6558
6559{
6560ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6561º º
6562º Speed-Pascal/2 Version 2.0 º
6563º º
6564º Speed-Pascal Component Classes (SPCC) º
6565º º
6566º This section: TBits Class Implementation º
6567º º
6568º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6569º º
6570ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6571}
6572
6573Destructor TBits.Destroy;
6574Begin
6575 FreeMem(FBits, (FSize + 31) Shr 5);
6576 FBits := Nil;
6577 Inherited Destroy;
6578End;
6579
6580Procedure TBits.Error;
6581Begin
6582 Raise EBitsError.Create(LoadNLSStr(SEBitsErrorText));
6583End;
6584
6585Function TBits.GetBit(Index: LongInt): Boolean;
6586Var
6587 Place: Cardinal;
6588Begin
6589 If (Index < 0) Or (Index >= FSize) Then Error;
6590 Place := 1 Shl (Index And 31);
6591 Index := Index Shr 5;
6592 Result := (FBits^[Index] And Place) <> 0;
6593End;
6594
6595Function TBits.OpenBit: LongInt;
6596Var
6597 I, J, K: LongInt;
6598 B: Cardinal;
6599Begin
6600 I := 0;
6601 J := (FSize + 31) Shr 5;
6602 While (I < J) And (FBits^[I] = 0) Do Inc(I);
6603 If I < J Then
6604 Begin
6605 K := 1;
6606 Result := I Shl 5;
6607 B := FBits^[I];
6608 While (B And K) = 0 Do
6609 Begin
6610 K := K Shl 1;
6611 Inc(Result);
6612 End;
6613 If Result >= FSize Then Result := -1;
6614 End
6615 Else Result := -1;
6616End;
6617
6618Procedure TBits.SetBit(Index: LongInt; bit: Boolean);
6619Var
6620 Place: Cardinal;
6621Begin
6622 If (Index < 0) Or (Index >= FSize) Then Error;
6623 Place := 1 Shl (Index And 31);
6624 Index := Index Shr 5;
6625 If bit Then FBits^[Index] := FBits^[Index] Or Place
6626 Else FBits^[Index] := FBits^[Index] And Not Place;
6627End;
6628
6629Procedure TBits.SetSize(NewSize: LongInt);
6630Begin
6631 If NewSize < 0 Then Error;
6632 If FSize = 0 Then FBits := AllocMem((NewSize + 31) Shr 3)
6633 Else FBits := ReAllocMem(FBits, (FSize + 31) Shr 3, (NewSize + 31) Shr 3);
6634 FSize := NewSize;
6635End;
6636
6637
6638{
6639ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6640º º
6641º Speed-Pascal/2 Version 2.0 º
6642º º
6643º Speed-Pascal Component Classes (SPCC) º
6644º º
6645º This section: TPropertyEditClassDialog Class Implementation º
6646º º
6647º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6648º º
6649ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6650}
6651
6652Type
6653 PPropertyEditClassItem=^TPropertyEditClassItem;
6654 TPropertyEditClassItem=Record
6655 ClassToEdit: TClass; //Editor Class (Class editors) Or parent Class (others)
6656 PropertyName:String[64]; //Property Name For normal editors
6657 ClassPropertyEditor: TClassPropertyEditorClass; //<>Nil For Class Property editors
6658 PropertyEditor:TPropertyEditorClass; //<>Nil For normal Property editors
6659 End;
6660
6661
6662{$HINTS OFF}
6663Function TClassPropertyEditor.Execute(Var ClassToEdit:TObject):TClassPropertyEditorReturn;
6664Begin
6665 Result:=peCancel; //Not Handled
6666End;
6667{$HINTS ON}
6668
6669Procedure AddPropertyEditor(OwnerClass:TClass;PropertyName:String;PropertyEditor:TPropertyEditorClass);
6670Var T:LongInt;
6671 dummy:PPropertyEditClassItem;
6672Begin
6673 UpcaseStr(PropertyName);
6674
6675 For T:=0 To PropertyEditDialogs.Count-1 Do
6676 Begin
6677 dummy:=PropertyEditDialogs.Items[T];
6678
6679 If dummy^.PropertyEditor<>Nil Then //normal Property Editor ??
6680 If OwnerClass=dummy^.ClassToEdit Then
6681 If dummy^.PropertyName=PropertyName Then
6682 Begin
6683 //replace existing
6684 dummy^.PropertyEditor:=PropertyEditor;
6685 Exit;
6686 End;
6687 End;
6688
6689 New(dummy);
6690 dummy^.ClassToEdit:=OwnerClass;
6691 dummy^.PropertyName:=PropertyName;
6692 dummy^.PropertyEditor:=PropertyEditor;
6693 PropertyEditDialogs.Add(dummy);
6694End;
6695
6696Function CallPropertyEditor(Owner:TComponent;PropertyName:String;Var Value;ValueLen:LongInt;
6697 Var List:TStringList):TPropertyEditorReturn;
6698Var T:LongInt;
6699 dummy:PPropertyEditClassItem;
6700 Editor:TPropertyEditor;
6701 S:String;
6702Label go;
6703Begin
6704 Result:=edNoEditor;
6705 UpcaseStr(PropertyName);
6706
6707 For T:=0 To PropertyEditDialogs.Count-1 Do
6708 Begin
6709 dummy:=PropertyEditDialogs.Items[T];
6710
6711 If dummy^.PropertyEditor<>Nil Then //normal Property Editor ??
6712 If Owner.ClassType=dummy^.ClassToEdit Then
6713 If dummy^.PropertyName=PropertyName Then
6714 Begin
6715go:
6716 Editor:=dummy^.PropertyEditor.Create(Nil);
6717 Editor.FOwner:=Owner;
6718 Editor.FPropertyName:=PropertyName;
6719 List.Create;
6720 Editor.FList:=List;
6721 Try
6722 If Editor Is TStringPropertyEditor Then
6723 Begin
6724 System.Move(Value,S,ValueLen);
6725 Result:=TStringPropertyEditor(Editor).Execute(S,ValueLen);
6726 System.Move(S,Value,ValueLen);
6727 End
6728 Else If Editor Is TShortIntPropertyEditor Then
6729 Result:=TShortIntPropertyEditor(Editor).Execute(ShortInt(Value))
6730 Else If Editor Is TIntegerPropertyEditor Then
6731 Result:=TIntegerPropertyEditor(Editor).Execute(Integer(Value))
6732 Else If Editor Is TLongIntPropertyEditor Then
6733 Result:=TLongIntPropertyEditor(Editor).Execute(LongInt(Value))
6734 Else Result:=Editor.Execute(Value,ValueLen);
6735 List:=Editor.FList;
6736 Editor.Destroy;
6737 Except
6738 Result:=edNoEditor;
6739 End;
6740
6741 Exit;
6742 End;
6743 End;
6744
6745 For T:=0 To PropertyEditDialogs.Count-1 Do
6746 Begin
6747 dummy:=PropertyEditDialogs.Items[T];
6748
6749 If dummy^.PropertyEditor<>Nil Then //normal Property Editor ??
6750 If Owner Is dummy^.ClassToEdit Then
6751 If dummy^.PropertyName=PropertyName Then
6752 Begin
6753 Goto go;
6754 End;
6755 End;
6756
6757 {Search In registered Property editors Of the complib}
6758 If @CallCompLibPropertyEditor<>Nil
6759 Then Result := CallCompLibPropertyEditor(Owner,PropertyName,Value,ValueLen,List);
6760End;
6761
6762Function PropertyEditorAvailable(OwnerClass:TClass;PropertyName:String):Boolean;
6763Var T:LongInt;
6764 dummy:PPropertyEditClassItem;
6765Begin
6766 Result:=False;
6767 UpcaseStr(PropertyName);
6768
6769 For T:=0 To PropertyEditDialogs.Count-1 Do
6770 Begin
6771 dummy:=PropertyEditDialogs.Items[T];
6772
6773 If dummy^.PropertyEditor<>Nil Then //normal Property Editor ??
6774 If dummy^.PropertyName=PropertyName Then
6775 If OwnerClass Is dummy^.ClassToEdit Then
6776 Begin
6777 Result:=True;
6778 Exit;
6779 End;
6780 End;
6781
6782 If @CallCompLibPropertyEditorAvailable<>Nil Then
6783 Result:=CallCompLibPropertyEditorAvailable(OwnerClass,PropertyName);
6784End;
6785
6786
6787Procedure AddClassPropertyEditor(ClassToEdit:TClass;PropertyEditor:TClassPropertyEditorClass);
6788Var T:LongInt;
6789 dummy:PPropertyEditClassItem;
6790Begin
6791 For T:=0 To PropertyEditDialogs.Count-1 Do
6792 Begin
6793 dummy:=PropertyEditDialogs.Items[T];
6794
6795 If dummy^.ClassPropertyEditor<>Nil Then //Class Property Editor ??
6796 If dummy^.ClassToEdit=ClassToEdit Then
6797 Begin
6798 //replace existing
6799 dummy^.ClassPropertyEditor:=PropertyEditor;
6800 Exit;
6801 End;
6802 End;
6803
6804 New(dummy);
6805 dummy^.ClassToEdit:=ClassToEdit;
6806 dummy^.ClassPropertyEditor:=PropertyEditor;
6807 PropertyEditDialogs.Add(dummy);
6808End;
6809
6810Function ClassPropertyEditorAvailable(ClassName:String):Boolean;
6811Var
6812 s1:String;
6813 AOwner:TClass;
6814
6815 Function process(Const s1:String):Boolean;
6816 Var T:LongInt;
6817 dummy:PPropertyEditClassItem;
6818 S:String;
6819 Begin
6820 Result:=False;
6821
6822 For T:=0 To PropertyEditDialogs.Count-1 Do
6823 Begin
6824 dummy:=PropertyEditDialogs.Items[T];
6825
6826 If dummy^.ClassPropertyEditor<>Nil Then //Class Property Editor ???
6827 Begin
6828 S:=dummy^.ClassToEdit.ClassName;
6829 UpcaseStr(S);
6830 If S=s1 Then
6831 Begin
6832 Result:=True;
6833 Exit;
6834 End;
6835 End;
6836 End;
6837 End;
6838
6839Label L,ex;
6840Begin
6841 Result:=False;
6842 s1:=ClassName;
6843 UpcaseStr(s1);
6844 If process(s1) Then
6845 Begin
6846 Result:=True;
6847 Exit;
6848 End;
6849
6850 //check If it Is Some derived Object
6851 AOwner:=SearchClassByName(ClassName);
6852 If AOwner=Nil Then goto ex;
6853L:
6854 AOwner:=AOwner.ClassParent;
6855
6856 If AOwner<>Nil Then
6857 Begin
6858 s1:=AOwner.ClassName;
6859 UpcaseStr(s1);
6860 If process(s1) Then Result:=True
6861 Else Goto L;
6862 End;
6863
6864ex:
6865 If @CallComplibClassPropertyEditorAvailable<>Nil Then
6866 Result:=Result Or CallCompLibClassPropertyEditorAvailable(ClassName);
6867End;
6868
6869Function CallClassPropertyEditor(Var ClassToEdit:TObject):TClassPropertyEditorReturn;
6870Var
6871 s1:String;
6872 AOwner:TClass;
6873 res:TClassPropertyEditorReturn;
6874
6875 Function process(Const s1:String):Boolean;
6876 Var T:LongInt;
6877 dummy:PPropertyEditClassItem;
6878 Editor:TClassPropertyEditor;
6879 S:String;
6880 Begin
6881 Result:=False;
6882
6883 For T:=0 To PropertyEditDialogs.Count-1 Do
6884 Begin
6885 dummy:=PropertyEditDialogs.Items[T];
6886
6887 If dummy^.ClassPropertyEditor<>Nil Then //Is it A Class Property Editor ??
6888 Begin
6889 S:=dummy^.ClassToEdit.ClassName;
6890 UpcaseStr(S);
6891 If S=s1 Then
6892 Begin
6893 Editor:=dummy^.ClassPropertyEditor.Create(Nil);
6894 res:=Editor.Execute(ClassToEdit);
6895 Editor.Destroy;
6896 Result:=True;
6897 Exit;
6898 End;
6899 End;
6900 End;
6901 End;
6902Begin
6903 Result:=peNoEditor;
6904 s1:=ClassToEdit.ClassName;
6905
6906 UpcaseStr(s1);
6907 If process(s1) Then
6908 Begin
6909 Result:=res;
6910 Exit;
6911 End;
6912
6913 {Search In registered Property editors Of the complib}
6914 If @CallCompLibClassPropertyEditor<>Nil
6915 Then Result := CallCompLibClassPropertyEditor(ClassToEdit);
6916 If Result<>peNoEditor Then exit;
6917
6918 //check If it Is Some derived Object
6919 AOwner := ClassToEdit.ClassType;
6920
6921 While AOwner.ClassParent <> Nil Do
6922 Begin
6923 AOwner:=AOwner.ClassParent;
6924
6925 s1:=AOwner.ClassName;
6926 UpcaseStr(s1);
6927 If process(s1) Then
6928 Begin
6929 Result:=res;
6930 Exit;
6931 End;
6932 End;
6933
6934 Result:=peNoEditor;
6935End;
6936
6937///////////////////////////////////////////////////////////////////////////
6938
6939Function GetExperts:TList;
6940Begin
6941 Result:=LibExperts;
6942End;
6943
6944
6945
6946{
6947ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6948º º
6949º Speed-Pascal/2 Version 2.0 º
6950º º
6951º Speed-Pascal Component Classes (SPCC) º
6952º º
6953º This section: TThread Class Implementation º
6954º º
6955º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6956º º
6957ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6958}
6959
6960Procedure TThread.SetSuspended(NewValue:Boolean);
6961Begin
6962 If NewValue Then Suspend
6963 Else Resume;
6964End;
6965
6966Const
6967 {$IFDEF OS2}
6968 PArray:Array[TThreadPriority] Of LongWord=
6969 (PRTYC_IDLETIME,PRTYC_REGULAR,PRTYC_REGULAR,PRTYC_REGULAR,PRTYC_REGULAR,
6970 PRTYC_REGULAR,PRTYC_TIMECRITICAL);
6971 PDelta:Array[tpIdle..tpTimeCritical] Of LongWord=
6972 (0,-31,-16,0,16,31,0);
6973 {$ENDIF}
6974 {$IFDEF Win95}
6975 PArray:Array[TThreadPriority] Of LongWord=
6976 (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
6977 THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,THREAD_PRIORITY_HIGHEST,
6978 THREAD_PRIORITY_TIME_CRITICAL);
6979 {$ENDIF}
6980
6981Procedure TThread.SetPriority(NewValue:TThreadPriority);
6982Begin
6983 FPriority:=NewValue;
6984 {$IFDEF OS2}
6985 If ThreadId<>0 Then DosSetPriority(2,PArray[NewValue],PDelta[NewValue],ThreadId);
6986 {$ENDIF}
6987 {$IFDEF Win95}
6988 SetThreadPriority(FHandle,PArray[NewValue]);
6989 {$ENDIF}
6990End;
6991
6992Procedure TThread.SyncTerminate;
6993Begin
6994 FOnTerminate(Self);
6995End;
6996
6997Procedure TThread.DoTerminate;
6998Begin
6999 If FOnTerminate<>Nil Then Synchronize(SyncTerminate);
7000End;
7001
7002Function ThreadLayer(Param:TThread):LongInt;
7003{$IFDEF OS2}
7004Var PAppHandle:LongWord;
7005 PAppQueueHandle:LongWord;
7006{$ENDIF}
7007Var FreeTerm:Boolean;
7008Begin
7009 {$IFDEF OS2}
7010 Param.FThreadId:=System.GetThreadId;
7011 If ApplicationType=1 Then
7012 Begin
7013 PAppHandle := WinInitializeAPI(0);
7014 PAppQueueHandle := WinCreateMsgQueueAPI(PAppHandle,0);
7015 End;
7016 {$ENDIF}
7017
7018 Param.Priority:=Param.FPriority;
7019 Param.Execute;
7020 Result:=Param.ReturnValue;
7021 FreeTerm:=Param.FreeOnTerminate;
7022 Param.FFinished:=True;
7023 Param.DoTerminate;
7024 If FreeTerm Then Param.Destroy;
7025
7026 {$IFDEF OS2}
7027 If ApplicationType=1 Then
7028 Begin
7029 WinDestroyMsgQueueAPI(PAppQueueHandle);
7030 WinTerminateAPI(PAppHandle);
7031 End;
7032 {$ENDIF}
7033
7034 System.EndThread(Result);
7035End;
7036
7037
7038Const ThreadWindow:LongWord=0;
7039 WM_EXECUTEPROC=WM_USER+1;
7040
7041Var ThreadDefWndProc:Function(Win,Msg,para1,para2:LongWord):LongWord;APIENTRY;
7042 MsgProc:Procedure;
7043 ProcessProc:Procedure;
7044
7045Procedure TThread.MsgIdle;
7046Begin
7047 ProcessProc;
7048End;
7049
7050Function ThreadWndProc(Win:LongWord;Msg,para1,para2:LongWord):LongWord;APIENTRY;
7051Var Thread:TThread;
7052Begin
7053 If Msg=WM_EXECUTEPROC Then
7054 Begin
7055 Thread:=TThread(para1);
7056 Thread.FMethod;
7057 Result:=0;
7058 End
7059 Else
7060 Begin
7061 If @ThreadDefWndProc<>Nil Then Result:=ThreadDefWndProc(Win,Msg,para1,para2)
7062 Else
7063 Begin
7064 {$IFDEF OS2}
7065 Result:=WinDefWindowProc(Win,Msg,para1,para2);
7066 {$ENDIF}
7067 {$IFDEF Win95}
7068 Result:=DefWindowProc(Win,Msg,para1,para2);
7069 {$ENDIF}
7070 End;
7071 End;
7072End;
7073
7074
7075Constructor TThread.ExtCreate(CreateSuspended:Boolean;StackSize:LongWord;Priority:TThreadPriority;
7076 Param:Pointer);
7077Var Options:LongWord;
7078Begin
7079 If ((ApplicationType=1)And(ThreadWindow=0)) Then
7080 Begin
7081 ThreadDefWndProc:=Nil;
7082 {$IFDEF OS2}
7083 ThreadWindow:=WinCreateWCWindow(HWND_DESKTOP,
7084 WC_BUTTON,
7085 '',
7086 0, //flStyle
7087 0,0, //leave This ON 0 - Set by .Show
7088 0,0, //Position And Size
7089 HWND_DESKTOP, //parent
7090 HWND_TOP, //Insert behind
7091 1, //Window Id
7092 Nil, //CtlData
7093 Nil); //Presparams
7094 ThreadDefWndProc:=Pointer(WinSubClassWindow(ThreadWindow,@ThreadWndProc));
7095 {$ENDIF}
7096 {$IFDEF Win95}
7097 ThreadWindow:=CreateWindow('BUTTON',
7098 '',
7099 0,
7100 0,0,
7101 0,0,
7102 HWND_DESKTOP,
7103 1,
7104 DllModule,
7105 Nil);
7106 ThreadDefWndProc:=Pointer(SetWindowLong(ThreadWindow,GWL_WNDPROC,LongInt(@ThreadWndProc)));
7107 {$ENDIF}
7108 End;
7109
7110 //Inherited Create;
7111 FSuspended:=CreateSuspended;
7112 Options:=0;
7113 If FSuspended Then Options:=Options Or THREAD_SUSPENDED;
7114 FPriority:=Priority;
7115 FParameter:=Param;
7116 FHandle:=BeginThread(Nil,StackSize,@ThreadLayer,Pointer(Self),Options,FThreadId);
7117End;
7118
7119Constructor TThread.Create(CreateSuspended: Boolean);
7120Begin
7121 TThread.ExtCreate(CreateSuspended,65535,tpNormal,Nil);
7122End;
7123
7124Destructor TThread.Destroy;
7125Begin
7126 If ((Not FFinished)And(Not FSuspended)) Then
7127 Begin
7128 Terminate;
7129 WaitFor;
7130 End
7131 Else If FSuspended Then
7132 Begin
7133 FFreeOnTerminate:=False;
7134 System.KillThread(FHandle);
7135 End;
7136 {$IFDEF Win95}
7137 If FHandle<>0 Then CloseHandle(FHandle);
7138 {$ENDIF}
7139 Inherited Destroy;
7140End;
7141
7142Function TThread.WaitFor:LongInt;
7143Var FreeIt:Boolean;
7144
7145Begin
7146 FreeIt:=FFreeOnTerminate;
7147 FFreeOnTerminate:=False;
7148 Repeat
7149 If ((ApplicationType=1)And(MsgProc<>Nil)) Then MsgProc
7150 Else Delay(50);
7151 Until FFinished;
7152 Result:=ReturnValue;
7153 If FreeIt Then Self.Destroy;
7154End;
7155
7156Procedure TThread.Terminate;
7157Begin
7158 FTerminated:=True;
7159End;
7160
7161Procedure TThread.Suspend;
7162Begin
7163 FSuspended:=True;
7164 {$IFDEF OS2}
7165 DosSuspendThread(FHandle);
7166 {$ENDIF}
7167 {$IFDEF Win95}
7168 SuspendThread(FHandle);
7169 {$ENDIF}
7170End;
7171
7172Procedure TThread.Resume;
7173Begin
7174 {$IFDEF OS2}
7175 If DosResumeThread(FHandle)=0 Then FSuspended:=False;
7176 {$ENDIF}
7177 {$IFDEF Win95}
7178 If ResumeThread(FHandle) = 1 Then FSuspended:=False;
7179 {$ENDIF}
7180End;
7181
7182//nach M”glichkeit nicht benutzen (statt dessen Terminate !), "abwrgen" des Threads
7183//falls keine M”glichkeit zur Abfrage von "Terminated" besteht
7184Procedure TThread.Kill;
7185Var FreeTerm:Boolean;
7186Begin
7187 Suspend;
7188 System.KillThread(FHandle);
7189 FreeTerm:=FreeOnTerminate;
7190 FFinished:=True;
7191 DoTerminate;
7192 If FreeTerm Then Self.Destroy;
7193End;
7194
7195Procedure TThread.ProcessMsgs;
7196Begin
7197 If ProcessProc<>Nil Then Synchronize(MsgIdle);
7198End;
7199
7200Procedure TThread.Synchronize(method:TThreadMethod);
7201Begin
7202 //If @method<>@MsgIdle Then ProcessMsgs;
7203 //MsgIdle;
7204 If ThreadWindow<>0 Then
7205 Begin
7206 FMethod:=method;
7207 {$IFDEF OS2}
7208 WinSendMsg(ThreadWindow,WM_EXECUTEPROC,LongWord(Self),0);
7209 {$ENDIF}
7210 {$IFDEF Win95}
7211 SendMessage(ThreadWindow,WM_EXECUTEPROC,LongWord(Self),0);
7212 {$ENDIF}
7213 End
7214 Else method;
7215End;
7216
7217{
7218ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
7219º º
7220º Speed-Pascal/2 Version 2.0 º
7221º º
7222º Speed-Pascal Component Classes (SPCC) º
7223º º
7224º This section: TCollectionItem Class Implementation º
7225º º
7226º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
7227º º
7228ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
7229}
7230
7231Function TCollectionItem.GetIndex:LongInt;
7232Begin
7233 If FCollection=Nil Then Result:=-1
7234 Else Result:=FCollection.FItems.IndexOf(Self);
7235End;
7236
7237Procedure TCollectionItem.SetCollection(NewValue:TCollection);
7238Begin
7239 If NewValue=FCollection Then Exit;
7240
7241 If FCollection<>Nil Then FCollection.RemoveItem(Self);
7242 If NewValue<>Nil Then NewValue.InsertItem(Self);
7243End;
7244
7245Procedure TCollectionItem.changed(AllItems:Boolean);
7246Begin
7247 If FCollection<>Nil Then If FCollection.FUpdateCount=0 Then
7248 Begin
7249 If AllItems Then FCollection.Update(Nil)
7250 Else FCollection.Update(Self);
7251 End;
7252End;
7253
7254Procedure TCollectionItem.SetIndex(NewIndex:LongInt);
7255Begin
7256 If NewIndex=Index Then Exit
7257 Else If Index>=0 Then
7258 Begin
7259 FCollection.FItems.Move(Index,NewIndex);
7260 changed(True);
7261 End;
7262End;
7263
7264Constructor TCollectionItem.Create(ACollection: TCollection);
7265Begin
7266 Inherited Create;
7267 collection:=ACollection;
7268End;
7269
7270Destructor TCollectionItem.Destroy;
7271Begin
7272 collection:=Nil;
7273 Inherited Destroy;
7274End;
7275
7276{
7277ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
7278º º
7279º Speed-Pascal/2 Version 2.0 º
7280º º
7281º Speed-Pascal Component Classes (SPCC) º
7282º º
7283º This section: TCollection Class Implementation º
7284º º
7285º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
7286º º
7287ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
7288}
7289
7290
7291Function TCollection.GetCount:LongInt;
7292Begin
7293 Result:=FItems.Count;
7294End;
7295
7296Procedure TCollection.InsertItem(Item:TCollectionItem);
7297Begin
7298 If Not (Item Is FItemClass) Then Raise EListError.Create(LoadNLSStr(SCollectionErrorText))
7299 Else
7300 Begin
7301 FItems.Add(Item);
7302 Item.FCollection:=Self;
7303 changed;
7304 End;
7305End;
7306
7307Procedure TCollection.RemoveItem(Item:TCollectionItem);
7308Begin
7309 FItems.Remove(Item);
7310 Item.FCollection:=Nil;
7311 changed;
7312End;
7313
7314Procedure TCollection.changed;
7315Begin
7316 If FUpdateCount=0 Then Update(Nil);
7317End;
7318
7319Function TCollection.GetItem(Index:LongInt):TCollectionItem;
7320Begin
7321 Result:=TCollectionItem(FItems[Index]);
7322End;
7323
7324Procedure TCollection.SetItem(Index:LongInt;Value:TCollectionItem);
7325Var dummy:TCollectionItem;
7326Begin
7327 dummy:=TCollectionItem(FItems[Index]);
7328 dummy.Assign(Value);
7329End;
7330
7331{$HINTS OFF}
7332Procedure TCollection.Update(Item:TCollectionItem);
7333Begin
7334End;
7335{$HINTS ON}
7336
7337Procedure TCollection.SetupComponent;
7338Begin
7339 Inherited SetupComponent;
7340
7341 Name:='Collection';
7342 FItemClass:=TCollectionItem;
7343 FItems.Create;
7344 Include(ComponentState,csDetail);
7345End;
7346
7347Destructor TCollection.Destroy;
7348Begin
7349 FUpdateCount:=1;
7350 Clear;
7351 FItems.Destroy;
7352
7353 Inherited Destroy;
7354End;
7355
7356Function TCollection.Add:TCollectionItem;
7357Begin
7358 Result:=FItemClass.Create(Self);
7359End;
7360
7361Function TCollection.Insert(Index:longint):TCollectionItem;
7362begin
7363 Result:=FItemClass.Create( nil ); // don't add to ourselves
7364 Result.FCollection := self; // don't assign thru property, would add it at the end of ourselves!!
7365 FItems.Insert( Index, Result );
7366 changed;
7367end;
7368
7369Procedure TCollection.Swap(Index1,Index2:longint);
7370var
7371 Item: TCollectionItem;
7372begin
7373 Item := FItems[ Index1 ];
7374 FItems[ Index1 ] := FItems[ Index2 ];
7375 FItems[ Index2 ] := Item;
7376end;
7377
7378Procedure TCollection.Assign(Source:TCollection);
7379Var dummy:TCollectionItem;
7380 T:LongInt;
7381Begin
7382 If ((Source=Nil)Or(Source=Self)) Then Exit;
7383
7384 BeginUpdate;
7385 Try
7386 Clear;
7387 For T:=0 To Source.Count-1 Do
7388 Begin
7389 dummy:=Self.Add;
7390 dummy.Assign(Source.Items[T]);
7391 End;
7392 Finally
7393 EndUpdate;
7394 End;
7395End;
7396
7397Procedure TCollection.BeginUpdate;
7398Begin
7399 Inc(FUpdateCount);
7400End;
7401
7402Procedure TCollection.EndUpdate;
7403Begin
7404 Dec(FUpdateCount);
7405 changed;
7406End;
7407
7408Procedure TCollection.Clear;
7409Var T:LongInt;
7410 dummy:TCollectionItem;
7411Begin
7412 If FItems.Count=0 Then Exit;
7413
7414 BeginUpdate;
7415 Try
7416 For T:=FItems.Count-1 DownTo 0 Do
7417 Begin
7418 dummy:=FItems[T];
7419 dummy.Destroy;
7420 End;
7421 FItems.Clear;
7422 Finally
7423 EndUpdate;
7424 End;
7425End;
7426
7427Begin
7428 LanguageMessages:=Nil;
7429 AppLanguage:='Default';
7430 MsgProc:=Nil;
7431 ProcessProc:=Nil;
7432 InsideCompLib:=False;
7433 InsideWriteSCU:=False;
7434 InsideWriteSCUAdr:=@InsideWriteSCU;
7435 InsideDesigner:=False;
7436 InsideLanguageDesigner:=False;
7437
7438 RegisteredClasses.Create;
7439 PropertyEditDialogs.Create;
7440 LibExperts.Create;
7441 LibExpertInstances.Create;
7442End.
Note: See TracBrowser for help on using the repository browser.