1 |
|
---|
2 | {ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
|
---|
3 | º º
|
---|
4 | º Sibyl Portable Component Classes º
|
---|
5 | º º
|
---|
6 | º Copyright (C) 1995,97 SpeedSoft Germany, All rights reserved. º
|
---|
7 | º º
|
---|
8 | ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ}
|
---|
9 |
|
---|
10 | Unit Classes;
|
---|
11 |
|
---|
12 |
|
---|
13 | Interface
|
---|
14 |
|
---|
15 | Uses Dos,SysUtils;
|
---|
16 |
|
---|
17 | {$IFDEF OS2}
|
---|
18 | Uses PmWin,BseDos;
|
---|
19 | {$ENDIF}
|
---|
20 | {$IFDEF Win95}
|
---|
21 | Uses WinUser,WinBase;
|
---|
22 | {$ENDIF}
|
---|
23 |
|
---|
24 | //TStream Seek origins
|
---|
25 | Const
|
---|
26 | soFromBeginning = 0;
|
---|
27 | soFromCurrent = 1;
|
---|
28 | soFromEnd = 2;
|
---|
29 |
|
---|
30 | Type
|
---|
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 |
|
---|
57 | Const
|
---|
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 |
|
---|
65 | Type
|
---|
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 |
|
---|
78 | Type
|
---|
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 |
|
---|
114 | Const
|
---|
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 |
|
---|
122 | Type
|
---|
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 |
|
---|
235 | Type
|
---|
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 |
|
---|
302 | Type
|
---|
303 | TDuplicates = (dupIgnore, dupAccept, dupError);
|
---|
304 |
|
---|
305 | TFreeStringListItem = Procedure(Sender:TObject;AObject:TObject) Of Object;
|
---|
306 |
|
---|
307 | Type
|
---|
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 |
|
---|
355 | Type
|
---|
356 | PStrItem = ^TStrItem;
|
---|
357 | TStrItem = Record
|
---|
358 | FObject: TObject;
|
---|
359 | FString: String;
|
---|
360 | End;
|
---|
361 |
|
---|
362 | Function NewStrItem(Const AString: String; AObject: TObject): PStrItem;
|
---|
363 | Procedure DisposeStrItem(P: PStrItem);
|
---|
364 |
|
---|
365 | Type
|
---|
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 |
|
---|
393 | Type
|
---|
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 |
|
---|
470 | Const
|
---|
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 |
|
---|
525 | Type
|
---|
526 | TColorName = Record
|
---|
527 | Name: String[20];
|
---|
528 | Value: LongInt;
|
---|
529 | End;
|
---|
530 |
|
---|
531 | Const
|
---|
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 |
|
---|
586 | Function ColorName(ColorValue:TColor):String;
|
---|
587 | Function ColorValue(ColorName:String):TColor;
|
---|
588 |
|
---|
589 |
|
---|
590 | Type
|
---|
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}
|
---|
607 | Const
|
---|
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 |
|
---|
633 | Type
|
---|
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 |
|
---|
855 | Procedure RegisterClasses(Const ComponentClasses: Array Of TComponentClass);
|
---|
856 | Function SearchClassByName(Const Name:String):TComponentClass;
|
---|
857 | Function CallReadProp(Objekt:TObject;FuncAddr:Pointer;Typ:Byte;
|
---|
858 | TypLen:LongInt;Value:Pointer):Boolean;
|
---|
859 | Function CallWriteProp(Objekt:TObject;ProcAddr:Pointer;Typ:Byte;
|
---|
860 | TypLen:LongInt;Value:Pointer):Boolean;
|
---|
861 |
|
---|
862 |
|
---|
863 | Type
|
---|
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 |
|
---|
888 | Function WritePropertiesToStream(FormList:TList):TMemoryStream;
|
---|
889 | Function WritePropertiesToFile(FileName:String;FormList:TList):Boolean;
|
---|
890 |
|
---|
891 |
|
---|
892 | Type
|
---|
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;
|
---|
897 | Const
|
---|
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 |
|
---|
909 | Const
|
---|
910 | mbYesNo=[mbYes,mbNo];
|
---|
911 | mbYesNoCancel=[mbYes,mbNo,mbCancel];
|
---|
912 | mbOkCancel=[mbOk,mbCancel];
|
---|
913 | mbAbortRetryIgnore=[mbAbort,mbRetry,mbIgnore];
|
---|
914 |
|
---|
915 |
|
---|
916 | Function MessageBox2(Const Msg:String;Typ:TMsgDlgType;Buttons:TMsgDlgButtons):TMsgDlgReturn;
|
---|
917 | Function ErrorBox2(Const Msg:String):TMsgDlgReturn;
|
---|
918 |
|
---|
919 | Function GetExperts:TList; {noch raus?}
|
---|
920 |
|
---|
921 |
|
---|
922 | Var RegisteredClasses:TList;
|
---|
923 | PropertyEditDialogs:TList;
|
---|
924 | LibExperts:TList;
|
---|
925 | LibExpertInstances:TList;
|
---|
926 |
|
---|
927 | Type
|
---|
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 |
|
---|
980 | Procedure RegisterClass(Const ComponentClass:TComponentClass);
|
---|
981 | Function GetClass(Const ClassName:String):TComponentClass;
|
---|
982 | Function FindClass(Const ClassName:String):TComponentClass;
|
---|
983 | Procedure UnRegisterClass(AClass:TComponentClass);
|
---|
984 | Procedure UnRegisterClasses(Const AClasses:Array of TComponentClass);
|
---|
985 | Procedure AddPropertyEditor(OwnerClass:TClass;PropertyName:String;PropertyEditor:TPropertyEditorClass);
|
---|
986 | Function CallPropertyEditor(Owner:TComponent;PropertyName:String;Var Value;ValueLen:LongInt;
|
---|
987 | Var List:TStringList):TPropertyEditorReturn;
|
---|
988 | Function PropertyEditorAvailable(OwnerClass:TClass;PropertyName:String):Boolean;
|
---|
989 |
|
---|
990 | Procedure AddClassPropertyEditor(ClassToEdit:TClass;PropertyEditor:TClassPropertyEditorClass);
|
---|
991 | Function CallClassPropertyEditor(Var ClassToEdit:TObject):TClassPropertyEditorReturn;
|
---|
992 | Function ClassPropertyEditorAvailable(ClassName:String):Boolean;
|
---|
993 |
|
---|
994 | Procedure AddDesignerPopupEvent(AString:TStringList;Caption:String;Id:LongInt);
|
---|
995 |
|
---|
996 | Function GetTempFileName:String;
|
---|
997 | Function InDesigner:Boolean;
|
---|
998 |
|
---|
999 |
|
---|
1000 | Implementation
|
---|
1001 |
|
---|
1002 | //!!!!!!!!!! bei nderungen auch Language Manager und SIB_DLG ndern!!!!!!!!!!!!!!!!!!!
|
---|
1003 | Type
|
---|
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 |
|
---|
1051 | Var LanguageMessages:PLanguageMessages;
|
---|
1052 | AppLanguage:String;
|
---|
1053 |
|
---|
1054 | Procedure DestroyMessages;
|
---|
1055 | Var dummy:PLanguageMessages;
|
---|
1056 | Begin
|
---|
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';
|
---|
1069 | End;
|
---|
1070 |
|
---|
1071 | Type TLanguageComponentKinds=(Captions,Menus,StringTables);
|
---|
1072 |
|
---|
1073 |
|
---|
1074 | Procedure SetupLanguageComponents(Component:TComponent;Items:PLanguageComponent;Kind:TLanguageComponentKinds);
|
---|
1075 | Var
|
---|
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 |
|
---|
1109 | Label skip;
|
---|
1110 | Begin
|
---|
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;
|
---|
1212 | skip:
|
---|
1213 | Items:=Items^.Next;
|
---|
1214 | End;
|
---|
1215 | End;
|
---|
1216 |
|
---|
1217 | Procedure GetLanguage(Component:TComponent;Var Language:String);
|
---|
1218 | Var Info:PLanguageInfo;
|
---|
1219 | Begin
|
---|
1220 | Info:=PLanguageInfo(Component.FLanguages);
|
---|
1221 | If ((Info=Nil)Or(Info^.CurrentLanguageName=Nil)) Then Language:='Default'
|
---|
1222 | Else Language:=Info^.CurrentLanguageName^;
|
---|
1223 | End;
|
---|
1224 |
|
---|
1225 | Procedure UpdateLanguageComponents(Items:PLanguageComponent;Kind:TLanguageComponentKinds);
|
---|
1226 | Var
|
---|
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 |
|
---|
1258 | Label skip;
|
---|
1259 | Begin
|
---|
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;
|
---|
1345 | skip:
|
---|
1346 | Items:=Items^.Next;
|
---|
1347 | End;
|
---|
1348 | End;
|
---|
1349 |
|
---|
1350 |
|
---|
1351 | Procedure SetLanguage(Component:TComponent;Language:String);
|
---|
1352 | Var Info:PLanguageInfo;
|
---|
1353 | Item:PLanguageItem;
|
---|
1354 | S,s1,s2:String;
|
---|
1355 | Begin
|
---|
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;
|
---|
1417 | End;
|
---|
1418 |
|
---|
1419 | Procedure GetAppLanguage(Var Language:String);
|
---|
1420 | Begin
|
---|
1421 | Language:=AppLanguage;
|
---|
1422 | End;
|
---|
1423 |
|
---|
1424 | Procedure SetAppLanguage(Const Language:String);
|
---|
1425 | Begin
|
---|
1426 | AppLanguage:=Language;
|
---|
1427 | End;
|
---|
1428 |
|
---|
1429 | Const
|
---|
1430 | {$IFDEF OS2}
|
---|
1431 | SCUVersion:String[5] = 'SCU01';
|
---|
1432 | {$ENDIF}
|
---|
1433 | {$IFDEF Win95}
|
---|
1434 | SCUVersion:String[5] = 'SCW01';
|
---|
1435 | {$ENDIF}
|
---|
1436 |
|
---|
1437 | Var
|
---|
1438 | InsideCompLib:Boolean;
|
---|
1439 | InsideWriteSCU:Boolean;
|
---|
1440 | InsideWriteSCUAdr:^Boolean;
|
---|
1441 | InsideDesigner:Boolean;
|
---|
1442 | InsideLanguageDesigner:Boolean;
|
---|
1443 |
|
---|
1444 | Type
|
---|
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 |
|
---|
1460 | Function GetTempFileName:String;
|
---|
1461 | Var Hour,Minute,Second,Sec100:Word;
|
---|
1462 | S,dir:String;
|
---|
1463 | Begin
|
---|
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;
|
---|
1480 | End;
|
---|
1481 |
|
---|
1482 |
|
---|
1483 | Function InDesigner:Boolean;
|
---|
1484 | Begin
|
---|
1485 | Result:=InsideDesigner;
|
---|
1486 | End;
|
---|
1487 |
|
---|
1488 |
|
---|
1489 | Function ColorName(ColorValue:TColor):String;
|
---|
1490 | Var T:LongInt;
|
---|
1491 | Begin
|
---|
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);
|
---|
1511 | End;
|
---|
1512 |
|
---|
1513 |
|
---|
1514 | Function ColorValue(ColorName:String):TColor;
|
---|
1515 | Var T:LongInt;
|
---|
1516 | C:Integer;
|
---|
1517 | S:String;
|
---|
1518 | Begin
|
---|
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;
|
---|
1545 | End;
|
---|
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 |
|
---|
1562 | Function TStream.CopyFrom(Source:TStream;Count:LongInt):LongInt;
|
---|
1563 | Var
|
---|
1564 | ActBufSize,T:LongInt;
|
---|
1565 | StreamBuffer:Pointer;
|
---|
1566 | Const
|
---|
1567 | MaxBufSize = $FFFF;
|
---|
1568 | Begin
|
---|
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;
|
---|
1595 | End;
|
---|
1596 |
|
---|
1597 | Function TStream.GetSize:LongInt;
|
---|
1598 | Var
|
---|
1599 | OldPos:LongInt;
|
---|
1600 | Result:LongInt;
|
---|
1601 | Begin
|
---|
1602 | OldPos:=GetPosition;
|
---|
1603 | Result:=Seek(0,Seek_End);
|
---|
1604 | SetPosition(OldPos);
|
---|
1605 | GetSize:=Result;
|
---|
1606 | End;
|
---|
1607 |
|
---|
1608 | Function TStream.EndOfData: Boolean;
|
---|
1609 | Begin
|
---|
1610 | Result := (Position >= Size);
|
---|
1611 | End;
|
---|
1612 |
|
---|
1613 | Function TStream.GetPosition:LongInt;
|
---|
1614 | Begin
|
---|
1615 | GetPosition:=Seek(0,Seek_Current);
|
---|
1616 | End;
|
---|
1617 |
|
---|
1618 | Procedure TStream.SetPosition(NewPos:LongInt);
|
---|
1619 | Begin
|
---|
1620 | Seek(NewPos,Seek_Begin);
|
---|
1621 | End;
|
---|
1622 |
|
---|
1623 | Procedure TStream.ReadBuffer(Var Buffer;Count:LongInt);
|
---|
1624 | Begin
|
---|
1625 | If Count=0 Then Exit; {Nothing To Read}
|
---|
1626 | If Read(Buffer,Count)<>Count Then Error(SStreamReadErrorText);
|
---|
1627 | End;
|
---|
1628 |
|
---|
1629 | Procedure TStream.WriteBuffer(Const Buffer;Count:LongInt);
|
---|
1630 | Begin
|
---|
1631 | If Count=0 Then Exit;
|
---|
1632 | If Write(Buffer,Count)<>Count Then Error(SStreamWriteErrorText);
|
---|
1633 | End;
|
---|
1634 |
|
---|
1635 | Procedure TStream.Error;
|
---|
1636 | Begin
|
---|
1637 | Raise EStreamError.Create(LoadNLSStr(ResourceId));
|
---|
1638 | End;
|
---|
1639 |
|
---|
1640 | Function TStream.ReadLn: String;
|
---|
1641 | Var
|
---|
1642 | Buffer: cstring[260];
|
---|
1643 | OldPos, Count, Temp: LongInt;
|
---|
1644 | Begin
|
---|
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;
|
---|
1661 | End;
|
---|
1662 |
|
---|
1663 | Procedure TStream.WriteLn(Const S: String);
|
---|
1664 | Var
|
---|
1665 | CRLF: Word;
|
---|
1666 | Begin
|
---|
1667 | CRLF := $0A0D;
|
---|
1668 | WriteBuffer(S[1], Length(S));
|
---|
1669 | WriteBuffer(CRLF, 2);
|
---|
1670 | End;
|
---|
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 |
|
---|
1686 | Constructor THandleStream.Create(AHandle: LongInt);
|
---|
1687 | Begin
|
---|
1688 | FHandle := AHandle;
|
---|
1689 | End;
|
---|
1690 |
|
---|
1691 | Function THandleStream.Read(Var Buffer; Count: LongInt): LongInt;
|
---|
1692 | Begin
|
---|
1693 | Result := FileRead(Handle, Buffer, Count);
|
---|
1694 | If Result = -1 Then Result := 0;
|
---|
1695 | End;
|
---|
1696 |
|
---|
1697 | Function THandleStream.Write(Const Buffer; Count: LongInt): LongInt;
|
---|
1698 | Var Temp:^Byte;
|
---|
1699 | Begin
|
---|
1700 | Temp:=@Buffer;
|
---|
1701 | Result := FileWrite(Handle, Temp^, Count);
|
---|
1702 | If Result = -1 Then Result := 0;
|
---|
1703 | End;
|
---|
1704 |
|
---|
1705 | Function THandleStream.Seek(Offset: LongInt; Origin: Word): LongInt;
|
---|
1706 | Begin
|
---|
1707 | Result := FileSeek(Handle, Offset, Origin);
|
---|
1708 | If Result < 0 Then Error(SStreamSeekErrorText);
|
---|
1709 | End;
|
---|
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 |
|
---|
1725 | Constructor TFileStream.Create(Const FileName:String;Mode:LongWord);
|
---|
1726 | Var
|
---|
1727 | SaveMode: LongWord;
|
---|
1728 | Begin
|
---|
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;
|
---|
1755 | End;
|
---|
1756 |
|
---|
1757 | Destructor TFileStream.Destroy;
|
---|
1758 | Begin
|
---|
1759 | {$I-}
|
---|
1760 | Close(PStreamFile);
|
---|
1761 | {$I+}
|
---|
1762 | Inherited Destroy;
|
---|
1763 | End;
|
---|
1764 |
|
---|
1765 | Function TFileStream.Read(Var Buffer;Count:LongInt):LongInt;
|
---|
1766 | Var
|
---|
1767 | Result:LongWord;
|
---|
1768 | Begin
|
---|
1769 | {$I-}
|
---|
1770 | BlockRead(PStreamFile,Buffer,Count,Result);
|
---|
1771 | {$I+}
|
---|
1772 | If InOutRes<>0 Then Error(SStreamReadErrorText);
|
---|
1773 | Read:=Result;
|
---|
1774 | End;
|
---|
1775 |
|
---|
1776 | Function TFileStream.Write(Const Buffer;Count:LongInt):LongInt;
|
---|
1777 | Var
|
---|
1778 | pb:Pointer;
|
---|
1779 | Result:LongWord;
|
---|
1780 | Begin
|
---|
1781 | pb:=@Buffer;
|
---|
1782 | {$I-}
|
---|
1783 | BlockWrite(PStreamFile,pb^,Count,Result);
|
---|
1784 | {$I+}
|
---|
1785 | If InOutRes<>0 Then Error(SStreamWriteErrorText);
|
---|
1786 | Write:=Result;
|
---|
1787 | End;
|
---|
1788 |
|
---|
1789 | Function TFileStream.Seek(Offset:LongInt;Origin:Word):LongInt;
|
---|
1790 | Var
|
---|
1791 | SaveSeekMode:LongWord;
|
---|
1792 | Begin
|
---|
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);
|
---|
1804 | End;
|
---|
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 |
|
---|
1820 | Const
|
---|
1821 | MemoryDelta = 8192;
|
---|
1822 |
|
---|
1823 | Destructor TMemoryStream.Destroy;
|
---|
1824 | Begin
|
---|
1825 | Clear;
|
---|
1826 | Inherited Destroy;
|
---|
1827 | End;
|
---|
1828 |
|
---|
1829 | Function TMemoryStream.Read(Var Buffer; Count: LongInt): LongInt;
|
---|
1830 | Begin
|
---|
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;
|
---|
1839 | End;
|
---|
1840 |
|
---|
1841 | Function TMemoryStream.Write(Const Buffer; Count: LongInt): LongInt;
|
---|
1842 | Var
|
---|
1843 | NewPos, Needed: LongInt;
|
---|
1844 | Begin
|
---|
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;
|
---|
1861 | End;
|
---|
1862 |
|
---|
1863 | Function TMemoryStream.Seek(Offset: LongInt; Origin: Word): LongInt;
|
---|
1864 | Begin
|
---|
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;
|
---|
1872 | End;
|
---|
1873 |
|
---|
1874 | Procedure TMemoryStream.LoadFromStream(Stream: TStream);
|
---|
1875 | Var
|
---|
1876 | ToDo: LongInt;
|
---|
1877 | Begin
|
---|
1878 | Stream.Position := 0;
|
---|
1879 | ToDo := Stream.Size;
|
---|
1880 | SetSize(ToDo);
|
---|
1881 | If ToDo <> 0 Then Stream.ReadBuffer(FBuffer^[0], ToDo);
|
---|
1882 | End;
|
---|
1883 |
|
---|
1884 | Procedure TMemoryStream.LoadFromFile(Const FileName:String);
|
---|
1885 | Var
|
---|
1886 | Source: TFileStream;
|
---|
1887 | Begin
|
---|
1888 | Source := TFileStream.Create(FileName, Stream_OpenRead);
|
---|
1889 | Try
|
---|
1890 | LoadFromStream(Source);
|
---|
1891 | Finally
|
---|
1892 | Source.Destroy;
|
---|
1893 | End;
|
---|
1894 | End;
|
---|
1895 |
|
---|
1896 | Procedure TMemoryStream.SaveToStream(Stream: TStream);
|
---|
1897 | Begin
|
---|
1898 | If FSize <> 0 Then Stream.WriteBuffer(FBuffer^[0], FSize);
|
---|
1899 | End;
|
---|
1900 |
|
---|
1901 | Procedure TMemoryStream.SaveToFile(Const FileName:String);
|
---|
1902 | Var
|
---|
1903 | Dest: TFileStream;
|
---|
1904 | Begin
|
---|
1905 | Dest := TFileStream.Create(FileName, Stream_Create);
|
---|
1906 | Try
|
---|
1907 | SaveToStream(Dest);
|
---|
1908 | Finally
|
---|
1909 | Dest.Destroy;
|
---|
1910 | End;
|
---|
1911 | End;
|
---|
1912 |
|
---|
1913 | Procedure TMemoryStream.SetCapacity(NewCapacity: LongInt);
|
---|
1914 | Begin
|
---|
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;
|
---|
1920 | End;
|
---|
1921 |
|
---|
1922 | Procedure TMemoryStream.SetSize(NewSize: LongInt);
|
---|
1923 | Begin
|
---|
1924 | Clear;
|
---|
1925 | SetCapacity(NewSize);
|
---|
1926 | FSize := NewSize;
|
---|
1927 | End;
|
---|
1928 |
|
---|
1929 | Procedure TMemoryStream.Clear;
|
---|
1930 | Begin
|
---|
1931 | SetCapacity(0);
|
---|
1932 | End;
|
---|
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 |
|
---|
1948 | Procedure TList.Error;
|
---|
1949 | Begin
|
---|
1950 | Raise EListError.Create(LoadNLSStr(SListErrorText));
|
---|
1951 | End;
|
---|
1952 |
|
---|
1953 |
|
---|
1954 | Function TList.Get(Index:LongInt):Pointer;
|
---|
1955 | Begin
|
---|
1956 | Result := Nil;
|
---|
1957 | If (Index < 0) Or (Index >= FCount) Then Error
|
---|
1958 | Else Result := FList^[Index];
|
---|
1959 | End;
|
---|
1960 |
|
---|
1961 |
|
---|
1962 | Procedure TList.Put(Index:LongInt;Item:Pointer);
|
---|
1963 | Begin
|
---|
1964 | If (Index < 0) Or (Index >= FCount) Then Error
|
---|
1965 | Else FList^[Index] := Item;
|
---|
1966 | End;
|
---|
1967 |
|
---|
1968 |
|
---|
1969 | Procedure TList.Grow;
|
---|
1970 | Var gr:LongInt;
|
---|
1971 | Begin
|
---|
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);
|
---|
1979 | End;
|
---|
1980 |
|
---|
1981 |
|
---|
1982 | Procedure TList.SetCapacity(NewCapacity:LongInt);
|
---|
1983 | Var NewList:PPointerList;
|
---|
1984 | Begin
|
---|
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;
|
---|
2000 | End;
|
---|
2001 |
|
---|
2002 |
|
---|
2003 | Procedure TList.SetCount(NewCount:LongInt);
|
---|
2004 | Var I:LongInt;
|
---|
2005 | Begin
|
---|
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;
|
---|
2018 | End;
|
---|
2019 |
|
---|
2020 |
|
---|
2021 | {--- Public part ------------------------------------------------------------}
|
---|
2022 |
|
---|
2023 | (* Clear the whole List And Destroy the List Object *)
|
---|
2024 | Destructor TList.Destroy;
|
---|
2025 | Begin
|
---|
2026 | Clear;
|
---|
2027 | Inherited Destroy;
|
---|
2028 | End;
|
---|
2029 |
|
---|
2030 |
|
---|
2031 | (* Clear the whole List And Release the allocated Memory *)
|
---|
2032 | Procedure TList.Clear;
|
---|
2033 | Begin
|
---|
2034 | SetCount(0);
|
---|
2035 | SetCapacity(0);
|
---|
2036 | End;
|
---|
2037 |
|
---|
2038 |
|
---|
2039 | (* Append A New Item At the End Of the List And return the New Index *)
|
---|
2040 | Function TList.Add(Item:Pointer):LongInt;
|
---|
2041 | Begin
|
---|
2042 | If FCount = FCapacity Then Grow;
|
---|
2043 | FList^[FCount] := Item;
|
---|
2044 | Inc(FCount);
|
---|
2045 | Result := FCount-1;
|
---|
2046 | End;
|
---|
2047 |
|
---|
2048 |
|
---|
2049 | (* Delete the Item And decrement the Count Of elements In the List *)
|
---|
2050 | Procedure TList.Delete(Index:LongInt);
|
---|
2051 | Begin
|
---|
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;
|
---|
2061 | End;
|
---|
2062 |
|
---|
2063 |
|
---|
2064 | (* Remove the Item And decrement the Count Of elements In the List *)
|
---|
2065 | Function TList.Remove(Item:Pointer):LongInt;
|
---|
2066 | Begin
|
---|
2067 | Result := IndexOf(Item);
|
---|
2068 | If Result <> -1 Then Delete(Result);
|
---|
2069 | End;
|
---|
2070 |
|
---|
2071 |
|
---|
2072 | (* Release the Memory allocated by the Item *)
|
---|
2073 | Procedure TList.FreeItem(Item:Pointer);
|
---|
2074 | Begin
|
---|
2075 | If FOnFreeItem <> Nil Then FOnFreeItem(Self,Item);
|
---|
2076 | End;
|
---|
2077 |
|
---|
2078 |
|
---|
2079 | (* Cut the specified Range out Of the List (including both indices) *)
|
---|
2080 | Procedure TList.Cut(Index1,Index2:LongInt);
|
---|
2081 | Var I,Swap:LongInt;
|
---|
2082 | Begin
|
---|
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;
|
---|
2100 | End;
|
---|
2101 |
|
---|
2102 |
|
---|
2103 | (* Insert A New Item At the specified Position In the List *)
|
---|
2104 | Procedure TList.Insert(Index:LongInt;Item:Pointer);
|
---|
2105 | Begin
|
---|
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;
|
---|
2115 | End;
|
---|
2116 |
|
---|
2117 |
|
---|
2118 | (* Exchange two Items In the List *)
|
---|
2119 | Procedure TList.Exchange(Index1,Index2:LongInt);
|
---|
2120 | Var Item:Pointer;
|
---|
2121 | Begin
|
---|
2122 | Item := Get(Index1);
|
---|
2123 | Put(Index1, Get(Index2));
|
---|
2124 | Put(Index2, Item);
|
---|
2125 | End;
|
---|
2126 |
|
---|
2127 |
|
---|
2128 | (* Move an Item To A New Position In the List *)
|
---|
2129 | Procedure TList.Move(CurIndex,NewIndex:LongInt);
|
---|
2130 | Var Item:Pointer;
|
---|
2131 | Begin
|
---|
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;
|
---|
2145 | End;
|
---|
2146 |
|
---|
2147 |
|
---|
2148 | (* return the Index Of an Item *)
|
---|
2149 | Function TList.IndexOf(Item:Pointer):LongInt;
|
---|
2150 | Begin
|
---|
2151 | For Result := 0 To FCount-1 Do
|
---|
2152 | If FList^[Result] = Item Then Exit;
|
---|
2153 | Result := -1;
|
---|
2154 | End;
|
---|
2155 |
|
---|
2156 |
|
---|
2157 | (* return the First Item In the List *)
|
---|
2158 | Function TList.First:Pointer;
|
---|
2159 | Begin
|
---|
2160 | Result := Get(0);
|
---|
2161 | End;
|
---|
2162 |
|
---|
2163 |
|
---|
2164 | (* return the Last Item In the List *)
|
---|
2165 | Function TList.Last:Pointer;
|
---|
2166 | Begin
|
---|
2167 | Result := Get(FCount-1);
|
---|
2168 | End;
|
---|
2169 |
|
---|
2170 |
|
---|
2171 | (* Expand the List If Capacity Is reached *)
|
---|
2172 | Function TList.Expand:TList;
|
---|
2173 | Begin
|
---|
2174 | If FCount = FCapacity Then Grow;
|
---|
2175 | Result := Self;
|
---|
2176 | End;
|
---|
2177 |
|
---|
2178 |
|
---|
2179 | (* Remove All Nil elements In the List *)
|
---|
2180 | Procedure TList.Pack;
|
---|
2181 | Var I:LongInt;
|
---|
2182 | Begin
|
---|
2183 | For I := FCount-1 DownTo 0 Do
|
---|
2184 | If FList^[I] = Nil Then Delete(I);
|
---|
2185 | End;
|
---|
2186 |
|
---|
2187 |
|
---|
2188 | Procedure 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 |
|
---|
2223 | Var
|
---|
2224 | I, C: LongInt;
|
---|
2225 | Begin
|
---|
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;
|
---|
2233 | End;
|
---|
2234 |
|
---|
2235 | Procedure TList.AddList(List:TList);
|
---|
2236 | var
|
---|
2237 | Source: PPointerList;
|
---|
2238 | Dest: PPointerList;
|
---|
2239 | Begin
|
---|
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 );
|
---|
2249 | End;
|
---|
2250 |
|
---|
2251 | Procedure TList.Assign(List:TList);
|
---|
2252 | Begin
|
---|
2253 | Clear;
|
---|
2254 | AddList(List);
|
---|
2255 | End;
|
---|
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 |
|
---|
2271 | Procedure TChainList.Error;
|
---|
2272 | Begin
|
---|
2273 | Raise EListError.Create(LoadNLSStr(SListErrorText));
|
---|
2274 | End;
|
---|
2275 |
|
---|
2276 |
|
---|
2277 | Function TChainList.Index2PLE(Index:LongInt):PChainListItem;
|
---|
2278 | Var I:LongInt;
|
---|
2279 | Begin
|
---|
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;
|
---|
2287 | End;
|
---|
2288 |
|
---|
2289 |
|
---|
2290 | Function TChainList.Item2PLE(Item:Pointer):PChainListItem;
|
---|
2291 | Begin
|
---|
2292 | Result := FList;
|
---|
2293 | While Result <> Nil Do
|
---|
2294 | Begin
|
---|
2295 | If Result^.Item = Item Then Exit;
|
---|
2296 | Result := Result^.Next;
|
---|
2297 | End;
|
---|
2298 | End;
|
---|
2299 |
|
---|
2300 |
|
---|
2301 | Function TChainList.PLE2Index(ple:PChainListItem):LongInt;
|
---|
2302 | Var ple1:PChainListItem;
|
---|
2303 | Begin
|
---|
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;
|
---|
2313 | End;
|
---|
2314 |
|
---|
2315 |
|
---|
2316 | Function TChainList.Item2Index(Item:Pointer):LongInt;
|
---|
2317 | Var ple:PChainListItem;
|
---|
2318 | Begin
|
---|
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;
|
---|
2328 | End;
|
---|
2329 |
|
---|
2330 |
|
---|
2331 | Procedure TChainList.Connect(ple1,ple2:PChainListItem);
|
---|
2332 | Begin
|
---|
2333 | If ple1 <> Nil Then ple1^.Next := ple2
|
---|
2334 | Else FList := ple2;
|
---|
2335 | If ple2 <> Nil Then ple2^.Prev := ple1
|
---|
2336 | Else FListEnd := ple1;
|
---|
2337 | End;
|
---|
2338 |
|
---|
2339 |
|
---|
2340 | Function TChainList.Get(Index:LongInt):Pointer;
|
---|
2341 | Var ple:PChainListItem;
|
---|
2342 | Begin
|
---|
2343 | ple := Index2PLE(Index);
|
---|
2344 | If ple = Nil Then Error;
|
---|
2345 | Result := ple^.Item;
|
---|
2346 | End;
|
---|
2347 |
|
---|
2348 |
|
---|
2349 | Procedure TChainList.Put(Index:LongInt;Item:Pointer);
|
---|
2350 | Var ple:PChainListItem;
|
---|
2351 | Begin
|
---|
2352 | ple := Index2PLE(Index);
|
---|
2353 | If ple = Nil Then Error;
|
---|
2354 | ple^.Item := Item;
|
---|
2355 | End;
|
---|
2356 |
|
---|
2357 |
|
---|
2358 |
|
---|
2359 | Destructor TChainList.Destroy;
|
---|
2360 | Begin
|
---|
2361 | Clear;
|
---|
2362 | Inherited Destroy;
|
---|
2363 | End;
|
---|
2364 |
|
---|
2365 |
|
---|
2366 | Procedure TChainList.Clear;
|
---|
2367 | Var I:LongInt;
|
---|
2368 | ple,plenext:PChainListItem;
|
---|
2369 | Begin
|
---|
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;
|
---|
2382 | End;
|
---|
2383 |
|
---|
2384 |
|
---|
2385 | Function TChainList.Add(Item:Pointer):LongInt;
|
---|
2386 | Var plenew:PChainListItem;
|
---|
2387 | Begin
|
---|
2388 | New(plenew);
|
---|
2389 | plenew^.Item := Item;
|
---|
2390 | plenew^.Next := Nil;
|
---|
2391 | Connect(FListEnd,plenew);
|
---|
2392 | FListEnd := plenew;
|
---|
2393 | Result := FCount;
|
---|
2394 | Inc(FCount);
|
---|
2395 | End;
|
---|
2396 |
|
---|
2397 |
|
---|
2398 | Function TChainList.Remove(Item:Pointer):LongInt;
|
---|
2399 | Var I:LongInt;
|
---|
2400 | ple:PChainListItem;
|
---|
2401 | Begin
|
---|
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;
|
---|
2418 | End;
|
---|
2419 |
|
---|
2420 |
|
---|
2421 | Procedure TChainList.Delete(Index:LongInt);
|
---|
2422 | Var ple:PChainListItem;
|
---|
2423 | Begin
|
---|
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);
|
---|
2432 | End;
|
---|
2433 |
|
---|
2434 |
|
---|
2435 | Procedure TChainList.FreeItem(Item:Pointer);
|
---|
2436 | Begin
|
---|
2437 | If FOnFreeItem <> Nil Then FOnFreeItem(Self,Item);
|
---|
2438 | End;
|
---|
2439 |
|
---|
2440 |
|
---|
2441 | Function TChainList.First:Pointer;
|
---|
2442 | Var ple:PChainListItem;
|
---|
2443 | Begin
|
---|
2444 | ple := FList;
|
---|
2445 | If ple = Nil Then Error;
|
---|
2446 | Result := ple^.Item;
|
---|
2447 | End;
|
---|
2448 |
|
---|
2449 |
|
---|
2450 | Function TChainList.Last:Pointer;
|
---|
2451 | Var ple:PChainListItem;
|
---|
2452 | Begin
|
---|
2453 | ple := FListEnd;
|
---|
2454 | If ple = Nil Then Error;
|
---|
2455 | Result := ple^.Item;
|
---|
2456 | End;
|
---|
2457 |
|
---|
2458 |
|
---|
2459 | Function TChainList.IndexOf(Item:Pointer):LongInt;
|
---|
2460 | Begin
|
---|
2461 | Result := Item2Index(Item);
|
---|
2462 | End;
|
---|
2463 |
|
---|
2464 |
|
---|
2465 | Procedure TChainList.Insert(Index:LongInt;Item:Pointer);
|
---|
2466 | Var ple,plenew:PChainListItem;
|
---|
2467 | Begin
|
---|
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);
|
---|
2481 | End;
|
---|
2482 |
|
---|
2483 |
|
---|
2484 | Procedure TChainList.Move(CurIndex,NewIndex:LongInt);
|
---|
2485 | Var TempItem:Pointer;
|
---|
2486 | Begin
|
---|
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);
|
---|
2496 | End;
|
---|
2497 |
|
---|
2498 |
|
---|
2499 | Procedure TChainList.Exchange(Index1,Index2:LongInt);
|
---|
2500 | Var ple1,ple2:PChainListItem;
|
---|
2501 | TempItem:Pointer;
|
---|
2502 | Begin
|
---|
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;
|
---|
2510 | End;
|
---|
2511 |
|
---|
2512 |
|
---|
2513 | Procedure TChainList.Pack;
|
---|
2514 | Var I:LongInt;
|
---|
2515 | ple,plenext:PChainListItem;
|
---|
2516 | Begin
|
---|
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;
|
---|
2529 | End;
|
---|
2530 |
|
---|
2531 |
|
---|
2532 | { --- Utility FUNCTIONs For TStrItem --- }
|
---|
2533 |
|
---|
2534 | Function NewStrItem(Const AString: String; AObject: TObject): PStrItem;
|
---|
2535 | Begin
|
---|
2536 | GetMem(Result, SizeOf(TObject) + Length(AString) + 1);
|
---|
2537 | Result^.FObject := AObject;
|
---|
2538 | Result^.FString := AString;
|
---|
2539 | End;
|
---|
2540 |
|
---|
2541 | Procedure DisposeStrItem(P: PStrItem);
|
---|
2542 | Begin
|
---|
2543 | FreeMem(P, SizeOf(TObject) + Length(P^.FString) + 1);
|
---|
2544 | End;
|
---|
2545 |
|
---|
2546 |
|
---|
2547 | { --- TStrings --- }
|
---|
2548 |
|
---|
2549 | Procedure TStrings.Append(Const S: String);
|
---|
2550 | Begin
|
---|
2551 | Add(S);
|
---|
2552 | End;
|
---|
2553 |
|
---|
2554 | Procedure TStrings.Put(Index: LongInt; Const S: String);
|
---|
2555 | Var Temp:TObject;
|
---|
2556 | Begin
|
---|
2557 | Temp := GetObject(Index);
|
---|
2558 | Delete(Index);
|
---|
2559 | InsertObject(Index, S, Temp);
|
---|
2560 | End;
|
---|
2561 |
|
---|
2562 | {$HINTS OFF}
|
---|
2563 | Function TStrings.GetObject(Index: LongInt): TObject;
|
---|
2564 | Begin
|
---|
2565 | Result := Nil;
|
---|
2566 | End;
|
---|
2567 |
|
---|
2568 | Procedure TStrings.PutObject(Index: LongInt; AObject: TObject);
|
---|
2569 | Begin
|
---|
2570 | End;
|
---|
2571 | {$HINTS ON}
|
---|
2572 |
|
---|
2573 | Function TStrings.Add(Const S: String): LongInt;
|
---|
2574 | Begin
|
---|
2575 | Result := Count;
|
---|
2576 | Insert(Result, S);
|
---|
2577 | End;
|
---|
2578 |
|
---|
2579 | Function TStrings.AddObject(Const S: String; AObject: TObject): LongInt;
|
---|
2580 | Begin
|
---|
2581 | Result := Add(S);
|
---|
2582 | PutObject(Result, AObject);
|
---|
2583 | End;
|
---|
2584 |
|
---|
2585 | Procedure TStrings.AddStrings(AStrings: TStrings);
|
---|
2586 | Var
|
---|
2587 | I: LongInt;
|
---|
2588 | Begin
|
---|
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;
|
---|
2596 | End;
|
---|
2597 |
|
---|
2598 | Procedure TStrings.Assign(AStrings: TStrings);
|
---|
2599 | Begin
|
---|
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;
|
---|
2608 | End;
|
---|
2609 |
|
---|
2610 | Procedure TStrings.BeginUpdate;
|
---|
2611 | Begin
|
---|
2612 | If FUpdateSemaphore = 0 Then SetUpdateState(True);
|
---|
2613 | Inc(FUpdateSemaphore);
|
---|
2614 | End;
|
---|
2615 |
|
---|
2616 | Procedure TStrings.EndUpdate;
|
---|
2617 | Begin
|
---|
2618 | Dec(FUpdateSemaphore);
|
---|
2619 | If FUpdateSemaphore = 0 Then SetUpdateState(False);
|
---|
2620 | End;
|
---|
2621 |
|
---|
2622 | Function TStrings.Equals(AStrings: TStrings): Boolean;
|
---|
2623 | Var
|
---|
2624 | N: LongInt;
|
---|
2625 | Begin
|
---|
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;
|
---|
2630 | End;
|
---|
2631 |
|
---|
2632 | Procedure TStrings.Exchange(Index1, Index2: LongInt);
|
---|
2633 | Var
|
---|
2634 | S: String;
|
---|
2635 | O: TObject;
|
---|
2636 | Begin
|
---|
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);
|
---|
2643 | End;
|
---|
2644 |
|
---|
2645 | Function TStrings.GetName(Index: LongInt): String;
|
---|
2646 | Var
|
---|
2647 | P: Integer;
|
---|
2648 | Begin
|
---|
2649 | Result := Get(Index);
|
---|
2650 | P := Pos('=', Result);
|
---|
2651 | System.Delete(Result, P, Length(Result) - P + 1);
|
---|
2652 | End;
|
---|
2653 |
|
---|
2654 | Procedure SingleLineToBuffer(Const S: String; Var P: PChar);
|
---|
2655 | Begin
|
---|
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);
|
---|
2661 | End;
|
---|
2662 |
|
---|
2663 | Function TStrings.GetText: PChar;
|
---|
2664 | Var
|
---|
2665 | N, BufSize: LongInt;
|
---|
2666 | BufPtr: PChar;
|
---|
2667 | Begin
|
---|
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;
|
---|
2675 | End;
|
---|
2676 |
|
---|
2677 | Function TStrings.GetTextStr: AnsiString;
|
---|
2678 | Var
|
---|
2679 | N, BufSize: LongInt;
|
---|
2680 | BufPtr: PChar;
|
---|
2681 | Begin
|
---|
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);
|
---|
2687 | End;
|
---|
2688 |
|
---|
2689 | Function TStrings.GetValue(Const Name: String): String;
|
---|
2690 | Begin
|
---|
2691 | FindValue(Name, Result);
|
---|
2692 | End;
|
---|
2693 |
|
---|
2694 | Function TStrings.FindValue(Const Name: String; Var Value: String): LongInt;
|
---|
2695 | Var
|
---|
2696 | P: Integer;
|
---|
2697 | Begin
|
---|
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 := '';
|
---|
2713 | End;
|
---|
2714 |
|
---|
2715 | Function TStrings.IndexOfName(Const Name: String): LongInt;
|
---|
2716 | Var
|
---|
2717 | P: Integer;
|
---|
2718 | S: String;
|
---|
2719 | Begin
|
---|
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;
|
---|
2727 | End;
|
---|
2728 |
|
---|
2729 | Function TStrings.IndexOf(Const S: String): LongInt;
|
---|
2730 | Begin
|
---|
2731 | For Result := 0 To Count-1 Do If CompareText(Get(Result), S) = 0 Then Exit;
|
---|
2732 | Result := -1;
|
---|
2733 | End;
|
---|
2734 |
|
---|
2735 | Function TStrings.IndexOfObject(AObject: TObject): LongInt;
|
---|
2736 | Begin
|
---|
2737 | For Result := 0 To Count-1 Do If GetObject(Result) = AObject Then Exit;
|
---|
2738 | Result := -1;
|
---|
2739 | End;
|
---|
2740 |
|
---|
2741 | Procedure TStrings.InsertObject(Index: LongInt; Const S: String; AObject: TObject);
|
---|
2742 | Begin
|
---|
2743 | Insert(Index, S);
|
---|
2744 | PutObject(Index, AObject);
|
---|
2745 | End;
|
---|
2746 |
|
---|
2747 | Procedure TStrings.LoadFromFile(Const FileName: String);
|
---|
2748 | Var
|
---|
2749 | Source: TFileStream;
|
---|
2750 | Begin
|
---|
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;
|
---|
2763 | End;
|
---|
2764 |
|
---|
2765 | Procedure TStrings.LoadFromStream(Stream: TStream);
|
---|
2766 | Begin
|
---|
2767 | BeginUpdate;
|
---|
2768 | Clear;
|
---|
2769 | Try
|
---|
2770 | While Not Stream.EndOfData Do Add(Stream.ReadLn);
|
---|
2771 | Finally
|
---|
2772 | EndUpdate;
|
---|
2773 | End;
|
---|
2774 | End;
|
---|
2775 |
|
---|
2776 | Procedure TStrings.Move(CurIndex, NewIndex: LongInt);
|
---|
2777 | Var
|
---|
2778 | O: TObject;
|
---|
2779 | S: String;
|
---|
2780 | Begin
|
---|
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;
|
---|
2788 | End;
|
---|
2789 |
|
---|
2790 | Procedure TStrings.SaveToFile(Const FileName: String);
|
---|
2791 | Var
|
---|
2792 | Dest: TFileStream;
|
---|
2793 | Begin
|
---|
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;
|
---|
2806 | End;
|
---|
2807 |
|
---|
2808 | Procedure TStrings.SaveToStream(Stream: TStream);
|
---|
2809 | Var
|
---|
2810 | N: LongInt;
|
---|
2811 | Begin
|
---|
2812 | For N := 0 To Count - 1 Do Stream.WriteLn(Get(N));
|
---|
2813 | End;
|
---|
2814 |
|
---|
2815 | Procedure 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 |
|
---|
2836 | Begin
|
---|
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;
|
---|
2847 | End;
|
---|
2848 |
|
---|
2849 | Procedure TStrings.SetTextStr(Const Value: AnsiString);
|
---|
2850 | Begin
|
---|
2851 | SetText(PChar(Value));
|
---|
2852 | End;
|
---|
2853 |
|
---|
2854 | {$HINTS OFF}
|
---|
2855 | Procedure TStrings.SetUpdateState(Updating: Boolean);
|
---|
2856 | Begin
|
---|
2857 | End;
|
---|
2858 | {$HINTS ON}
|
---|
2859 |
|
---|
2860 | Procedure TStrings.SetValue(Const Name, Value: String);
|
---|
2861 | Var
|
---|
2862 | I: LongInt;
|
---|
2863 | S: String;
|
---|
2864 | Begin
|
---|
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;
|
---|
2875 | End;
|
---|
2876 |
|
---|
2877 | { --- TStringList --- }
|
---|
2878 |
|
---|
2879 | Constructor TStringList.Create;
|
---|
2880 | Begin
|
---|
2881 | Inherited Create;
|
---|
2882 | FList := TList.Create;
|
---|
2883 | FCaseSensitive := False;
|
---|
2884 | End;
|
---|
2885 |
|
---|
2886 | Destructor TStringList.Destroy;
|
---|
2887 | Begin
|
---|
2888 | { Die folgenden zwei Zeilen spter wieder ndern }
|
---|
2889 | Pointer(FOnChanging) := Nil;
|
---|
2890 | Pointer(FOnChange) := Nil;
|
---|
2891 | Clear;
|
---|
2892 | FList.Destroy;
|
---|
2893 | FList := Nil;
|
---|
2894 | Inherited Destroy;
|
---|
2895 | End;
|
---|
2896 |
|
---|
2897 | Function TStringList.Add(Const S: String): LongInt;
|
---|
2898 | Begin
|
---|
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;
|
---|
2913 | End;
|
---|
2914 |
|
---|
2915 | Procedure TStringList.changed;
|
---|
2916 | Begin
|
---|
2917 | If (FUpdateSemaphore = 0) And (FOnChange <> Nil) Then FOnChange(Self);
|
---|
2918 | End;
|
---|
2919 |
|
---|
2920 | Procedure TStringList.Changing;
|
---|
2921 | Begin
|
---|
2922 | If (FUpdateSemaphore = 0) And (FOnChanging <> Nil) Then FOnChanging(Self);
|
---|
2923 | End;
|
---|
2924 |
|
---|
2925 | Procedure TStringList.Clear;
|
---|
2926 | Var
|
---|
2927 | N: LongInt;
|
---|
2928 | Begin
|
---|
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;
|
---|
2937 | End;
|
---|
2938 |
|
---|
2939 | Procedure TStringList.Delete(Index: LongInt);
|
---|
2940 | Begin
|
---|
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;
|
---|
2955 | End;
|
---|
2956 |
|
---|
2957 | Procedure TStringList.FreeItem(AObject:TObject);
|
---|
2958 | Begin
|
---|
2959 | If FOnFreeItem <> Nil Then FOnFreeItem(Self,AObject);
|
---|
2960 | End;
|
---|
2961 |
|
---|
2962 | Procedure TStringList.Exchange(Index1, Index2: LongInt);
|
---|
2963 | Begin
|
---|
2964 | Changing;
|
---|
2965 | FList.Exchange(Index1, Index2);
|
---|
2966 | changed;
|
---|
2967 | End;
|
---|
2968 |
|
---|
2969 | Function TStringList.Find(Const S: String; Var Index: LongInt): Boolean;
|
---|
2970 | Var
|
---|
2971 | Low, High: LongInt;
|
---|
2972 | CMP: Integer;
|
---|
2973 | DoCompare: Function(Const S, T: String): Integer;
|
---|
2974 |
|
---|
2975 | Begin
|
---|
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;
|
---|
3003 | End;
|
---|
3004 |
|
---|
3005 | Function TStringList.Get(Index: LongInt): String;
|
---|
3006 | Begin
|
---|
3007 | Result := PStrItem(FList.Get(Index))^.FString;
|
---|
3008 | End;
|
---|
3009 |
|
---|
3010 | Function TStringList.GetCount: LongInt;
|
---|
3011 | Begin
|
---|
3012 | Result := FList.Count;
|
---|
3013 | End;
|
---|
3014 |
|
---|
3015 | Function TStringList.GetObject(Index: LongInt): TObject;
|
---|
3016 | Begin
|
---|
3017 | Result := PStrItem(FList.Get(Index))^.FObject;
|
---|
3018 | End;
|
---|
3019 |
|
---|
3020 | Function TStringList.IndexOf(Const S: String): LongInt;
|
---|
3021 | Begin
|
---|
3022 | If Not Find(S, Result) Then Result := -1;
|
---|
3023 | End;
|
---|
3024 |
|
---|
3025 | Procedure TStringList.Insert(Index: LongInt; Const S: String);
|
---|
3026 | Begin
|
---|
3027 | Changing;
|
---|
3028 | If FSorted Then Raise EListError.Create(LoadNLSStr(SStringListInsertErrorText))
|
---|
3029 | Else FList.Insert(Index, NewStrItem(S, Nil));
|
---|
3030 | changed;
|
---|
3031 | End;
|
---|
3032 |
|
---|
3033 | Procedure TStringList.Put(Index: LongInt; Const S: String);
|
---|
3034 | Var TempObj:TObject;
|
---|
3035 | pstr:PStrItem;
|
---|
3036 | Begin
|
---|
3037 | Changing;
|
---|
3038 | pstr := FList.Get(Index);
|
---|
3039 | TempObj := pstr^.FObject;
|
---|
3040 | DisposeStrItem(pstr);
|
---|
3041 | FList.Put(Index, NewStrItem(S, TempObj));
|
---|
3042 | changed;
|
---|
3043 | End;
|
---|
3044 |
|
---|
3045 | Procedure TStringList.PutObject(Index: LongInt; AObject: TObject);
|
---|
3046 | Var
|
---|
3047 | P: PStrItem;
|
---|
3048 | Begin
|
---|
3049 | P := FList.Get(Index);
|
---|
3050 | P^.FObject := AObject;
|
---|
3051 | End;
|
---|
3052 |
|
---|
3053 | Procedure TStringList.BottomUpHeapSort;
|
---|
3054 | Var
|
---|
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 |
|
---|
3081 | Var
|
---|
3082 | I, C: LongInt;
|
---|
3083 | Begin
|
---|
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;
|
---|
3094 | End;
|
---|
3095 |
|
---|
3096 | Procedure TStringList.SetCaseSensitive(Value: Boolean);
|
---|
3097 | Var
|
---|
3098 | old: Boolean;
|
---|
3099 | Begin
|
---|
3100 | Changing;
|
---|
3101 | old := FCaseSensitive;
|
---|
3102 | FCaseSensitive := Value;
|
---|
3103 | If FSorted And (FCaseSensitive <> old) Then Sort;
|
---|
3104 | changed;
|
---|
3105 | End;
|
---|
3106 |
|
---|
3107 | Procedure TStringList.SetSorted(Value: Boolean);
|
---|
3108 | Begin
|
---|
3109 | Changing;
|
---|
3110 | If (Not FSorted) And Value Then Sort;
|
---|
3111 | FSorted := Value;
|
---|
3112 | changed;
|
---|
3113 | End;
|
---|
3114 |
|
---|
3115 | Procedure TStringList.SetUpdateState(Updating: Boolean);
|
---|
3116 | Begin
|
---|
3117 | If Updating Then Changing
|
---|
3118 | Else changed;
|
---|
3119 | End;
|
---|
3120 |
|
---|
3121 | Procedure TStringList.Sort;
|
---|
3122 | Begin
|
---|
3123 | If Count > 1 Then
|
---|
3124 | Begin
|
---|
3125 | Changing;
|
---|
3126 | BottomUpHeapSort;
|
---|
3127 | changed;
|
---|
3128 | End;
|
---|
3129 | End;
|
---|
3130 |
|
---|
3131 | Function TStringList.GetValuePtr(Index:Longint): PString;
|
---|
3132 | var
|
---|
3133 | Item: PStrItem;
|
---|
3134 | Begin
|
---|
3135 | Item := PStrItem(FList.Get(Index));
|
---|
3136 | Result := Addr( Item^.FString );
|
---|
3137 | End;
|
---|
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 |
|
---|
3154 | Function MessageBox2(Const Msg:String;Typ:TMsgDlgType;Buttons:TMsgDlgButtons):TMsgDlgReturn;
|
---|
3155 | Var C,Title:cstring;
|
---|
3156 | iFlags:LongWord;
|
---|
3157 | mresult:LongWord;
|
---|
3158 | Begin
|
---|
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}
|
---|
3293 | End;
|
---|
3294 |
|
---|
3295 |
|
---|
3296 | Function ErrorBox2(Const Msg:String):TMsgDlgReturn;
|
---|
3297 | Begin
|
---|
3298 | Beep(1000,200);
|
---|
3299 | Result:=MessageBox2(Msg,mtError,[mbOk]);
|
---|
3300 | End;
|
---|
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 |
|
---|
3318 | Type
|
---|
3319 | PResourceEntry=^TResourceEntry;
|
---|
3320 | TResourceEntry=Record
|
---|
3321 | ResName:TResourceName;
|
---|
3322 | DataOffset:LongInt;
|
---|
3323 | DataLen:LongInt;
|
---|
3324 | End;
|
---|
3325 |
|
---|
3326 | Function CompareResMem(Var Buf1,Buf2;Size:LongWord):Boolean;
|
---|
3327 | Var R:Boolean;
|
---|
3328 | Begin
|
---|
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;
|
---|
3341 | End;
|
---|
3342 |
|
---|
3343 | {$HINTS OFF}
|
---|
3344 | Function TResourceStream.NewResourceEntry(Const ResName:TResourceName;
|
---|
3345 | Var Data;DataLen:LongInt):Boolean;
|
---|
3346 | Var dummy:PResourceEntry;
|
---|
3347 | SavePos,T,HeadPos:LongInt;
|
---|
3348 | P:Pointer;
|
---|
3349 | Label L;
|
---|
3350 | Begin
|
---|
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);
|
---|
3393 | L:
|
---|
3394 | //Write Position Of Resource
|
---|
3395 | If SCUStream.Write(HeadPos,4)=0 Then Exit;
|
---|
3396 |
|
---|
3397 | Result:=True;
|
---|
3398 | End;
|
---|
3399 | {$HINTS ON}
|
---|
3400 |
|
---|
3401 | Function TResourceStream.WriteResourcesToStream(Stream:TMemoryStream):Boolean;
|
---|
3402 | Var T,t1:LongInt;
|
---|
3403 | PatchOffset,StartPos:LongInt;
|
---|
3404 | dummy:PResourceEntry;
|
---|
3405 | P:Pointer;
|
---|
3406 | Begin
|
---|
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;
|
---|
3444 | End;
|
---|
3445 |
|
---|
3446 | Destructor TResourceStream.Destroy;
|
---|
3447 | Var T:LongInt;
|
---|
3448 | dummy:PResourceEntry;
|
---|
3449 | Begin
|
---|
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;
|
---|
3462 | End;
|
---|
3463 |
|
---|
3464 | Type
|
---|
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 |
|
---|
3499 | Procedure TPersistent.AssignError(Source:TPersistent);
|
---|
3500 | Var Msg:String;
|
---|
3501 | Begin
|
---|
3502 | If Source=Nil Then Msg:='Nil'
|
---|
3503 | Else Msg:=Source.ClassName;
|
---|
3504 | Raise EConvertError.Create('Convert '+ClassName+' to '+Msg+'.');
|
---|
3505 | End;
|
---|
3506 |
|
---|
3507 | Procedure TPersistent.AssignTo(Dest:TPersistent);
|
---|
3508 | Begin
|
---|
3509 | Dest.AssignError(Self);
|
---|
3510 | End;
|
---|
3511 |
|
---|
3512 | Procedure TPersistent.Assign(Source:TPersistent);
|
---|
3513 | Begin
|
---|
3514 | If Source<>Nil Then Source.AssignTo(Self)
|
---|
3515 | Else AssignError(nil);
|
---|
3516 | End;
|
---|
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 |
|
---|
3533 | Const //OldStyleFormat:Boolean=False;
|
---|
3534 | LastSCUForm:TComponent=Nil;
|
---|
3535 |
|
---|
3536 | Function GetClassNameFromSCU(NameTable:Pointer;Namep:LongWord):String;
|
---|
3537 | Var ps:^String;
|
---|
3538 | Begin
|
---|
3539 | ps:=NameTable;
|
---|
3540 | Inc(ps,Namep);
|
---|
3541 | Result:=ps^;
|
---|
3542 | End;
|
---|
3543 |
|
---|
3544 | Function GetParentSCUFormDesign(Component:TComponent):TComponent;
|
---|
3545 | Var AOwner:TComponent;
|
---|
3546 | Begin
|
---|
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
|
---|
3563 | End;
|
---|
3564 |
|
---|
3565 | Function GetParentSCUFormRuntime(Component:TComponent;Name:String):TComponent;
|
---|
3566 | Var AOwner:TComponent;
|
---|
3567 | S:String;
|
---|
3568 | Begin
|
---|
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
|
---|
3586 | End;
|
---|
3587 |
|
---|
3588 | Procedure InsertSCUMethod(AParent,Objekt:TComponent;
|
---|
3589 | ProcName,ProcParams,PropertyName:String);
|
---|
3590 | Var Methods:PIDE_Methods;
|
---|
3591 | S,s2:String[64];
|
---|
3592 | s1,s3:String;
|
---|
3593 | Own:PIDE_OwnerList;
|
---|
3594 | Label L;
|
---|
3595 | Begin
|
---|
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;
|
---|
3630 | L:
|
---|
3631 | New(Own);
|
---|
3632 | AssignStr(Own^.PropertyName,PropertyName);
|
---|
3633 | Own^.Objekt:=Objekt;
|
---|
3634 | Methods^.Owners.Add(Own);
|
---|
3635 | End;
|
---|
3636 |
|
---|
3637 | Function GetSCUProcParamsFromName(Objekt:TComponent;PropertyName:String):String;
|
---|
3638 | Var p1:^LongWord;
|
---|
3639 | B:Byte;
|
---|
3640 | S,s1:String;
|
---|
3641 | ps:^String;
|
---|
3642 | pParent:Pointer;
|
---|
3643 | Scope:Byte;
|
---|
3644 | NameIndex:LongInt;
|
---|
3645 | NameTable:^String;
|
---|
3646 | Label L,ex,again;
|
---|
3647 | Begin
|
---|
3648 | //Search PropertyName
|
---|
3649 | UpcaseStr(PropertyName);
|
---|
3650 | p1:=Objekt.ClassInfo;
|
---|
3651 | again:
|
---|
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;
|
---|
3707 | ex:
|
---|
3708 | Result:='?';
|
---|
3709 | Exit; //Not found;
|
---|
3710 | L:
|
---|
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;
|
---|
3744 | End;
|
---|
3745 |
|
---|
3746 |
|
---|
3747 | Type 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 |
|
---|
3758 | Const PropertyLinks:PPropertyLink=Nil;
|
---|
3759 |
|
---|
3760 |
|
---|
3761 | Function GetPropertyTypeInfo2(Instance:TComponent;PropertyName:String;Var Info:TPropertyTypeInfo):Boolean;
|
---|
3762 | Var L,C:^LongWord;
|
---|
3763 | ps:^String;
|
---|
3764 | S:String;
|
---|
3765 | Label weiter;
|
---|
3766 | Begin
|
---|
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;
|
---|
3827 | weiter:
|
---|
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;
|
---|
3835 | End;
|
---|
3836 |
|
---|
3837 |
|
---|
3838 | Function GetReference(Owner:TComponent):TComponent;
|
---|
3839 | Begin
|
---|
3840 | Result:=Owner.FReference;
|
---|
3841 | End;
|
---|
3842 |
|
---|
3843 | Procedure SetReference(Owner,Ref:TComponent);
|
---|
3844 | Begin
|
---|
3845 | Owner.FReference:=Ref;
|
---|
3846 | End;
|
---|
3847 |
|
---|
3848 |
|
---|
3849 | {$HINTS OFF}
|
---|
3850 | Procedure TComponent.UpdateLinkList(Const PropertyName:String;LinkList:TList);
|
---|
3851 | Begin
|
---|
3852 | //LinkList Is A List Of TComponent Instances that the Inspector
|
---|
3853 | //will display For the specified Property, you may only Remove Items !
|
---|
3854 | End;
|
---|
3855 | {$HINTS ON}
|
---|
3856 |
|
---|
3857 |
|
---|
3858 | Type 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}
|
---|
3865 | Function TComponent.ReadPropertiesSCU(COwner:TComponent;Namep,Resourcep:Pointer;Var ClassPointer:Pointer):Boolean;
|
---|
3866 | Var 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;
|
---|
3884 | Label L,err;
|
---|
3885 | Begin
|
---|
3886 | Result:=False;
|
---|
3887 | P:=ClassPointer;
|
---|
3888 | SectionLen:=P^;
|
---|
3889 | Inc(P,4); //overread Property section len
|
---|
3890 | L:
|
---|
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
|
---|
3938 | err:
|
---|
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 einfgen
|
---|
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;
|
---|
4153 | End;
|
---|
4154 | {$HINTS ON}
|
---|
4155 |
|
---|
4156 |
|
---|
4157 | Procedure TComponent.ReadResourceSCU(ResourceTable:Pointer;Var ClassP:Pointer);
|
---|
4158 | Var 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;
|
---|
4167 | Label L;
|
---|
4168 | Begin
|
---|
4169 | L:
|
---|
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}
|
---|
4194 | End;
|
---|
4195 |
|
---|
4196 |
|
---|
4197 | Procedure HandlePropertyLinks(Component:TComponent);
|
---|
4198 | Var dummy,Next:PPropertyLink;
|
---|
4199 | P,p2:Pointer;
|
---|
4200 | T,t1:LongInt;
|
---|
4201 | Comp,Comp1,Comp2:TComponent;
|
---|
4202 | S:String;
|
---|
4203 | Label found,again;
|
---|
4204 | Begin
|
---|
4205 | dummy:=PropertyLinks;
|
---|
4206 | While dummy<>Nil Do
|
---|
4207 | Begin
|
---|
4208 | UpcaseStr(dummy^.LinkName);
|
---|
4209 | P:=Nil;
|
---|
4210 | Comp1:=Component;
|
---|
4211 | again:
|
---|
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;
|
---|
4250 | found:
|
---|
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;
|
---|
4292 | End;
|
---|
4293 |
|
---|
4294 |
|
---|
4295 | Function TComponent.ReadComponentsSCU(NameTable,ResourceTable:Pointer;Var ClassP:Pointer):Boolean;
|
---|
4296 | Var 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 |
|
---|
4339 | Label skip,skipIt;
|
---|
4340 | Begin
|
---|
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}
|
---|
4420 | skipIt:
|
---|
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;
|
---|
4469 | skip:
|
---|
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;
|
---|
4485 | End;
|
---|
4486 |
|
---|
4487 |
|
---|
4488 | Function SearchClassSCU(Data:Pointer;NameToFind:String;ObjectCount:LongInt;ClassUnit:String):Pointer;
|
---|
4489 | Var dummy:^LongWord;
|
---|
4490 | len:LongWord;
|
---|
4491 | Count:LongInt;
|
---|
4492 | ps:^String;
|
---|
4493 | S,D,N,E:String;
|
---|
4494 | Label L;
|
---|
4495 | Begin
|
---|
4496 | Result:=Nil;
|
---|
4497 | Count:=0;
|
---|
4498 | UpcaseStr(ClassUnit);
|
---|
4499 | L:
|
---|
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;
|
---|
4524 | End;
|
---|
4525 |
|
---|
4526 |
|
---|
4527 | Procedure TComponent.SetupSCU;
|
---|
4528 | Var
|
---|
4529 | SaveSCU:Pointer;
|
---|
4530 | OldInsideDesigner:Boolean;
|
---|
4531 | Begin
|
---|
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;
|
---|
4547 | End;
|
---|
4548 |
|
---|
4549 |
|
---|
4550 | {$HINTS OFF}
|
---|
4551 | Procedure TComponent.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
|
---|
4552 | Begin
|
---|
4553 | End;
|
---|
4554 |
|
---|
4555 | Function TComponent.WriteSCUResource(Stream:TResourceStream):Boolean;
|
---|
4556 | Begin
|
---|
4557 | Result:=True;
|
---|
4558 | End;
|
---|
4559 |
|
---|
4560 | Procedure TComponent.LoadedFromSCU(SCUParent:TComponent);
|
---|
4561 | Begin
|
---|
4562 | Exclude(FComponentState, csReading);
|
---|
4563 | Exclude(FComponentState, csLoading);
|
---|
4564 | Include(FComponentState, csLoaded);
|
---|
4565 | End;
|
---|
4566 |
|
---|
4567 | Procedure TComponent.LoadingFromSCU(SCUParent:TComponent);
|
---|
4568 | Begin
|
---|
4569 | Include(FComponentState, csReading);
|
---|
4570 | Include(FComponentState, csLoading);
|
---|
4571 | Exclude(FComponentState, csLoaded);
|
---|
4572 | End;
|
---|
4573 | {$HINTS ON}
|
---|
4574 |
|
---|
4575 | Procedure TComponent.Loaded;
|
---|
4576 | Begin
|
---|
4577 | End;
|
---|
4578 |
|
---|
4579 |
|
---|
4580 | Procedure TComponent.SetupComponent;
|
---|
4581 | Begin
|
---|
4582 | //Name := 'Component';
|
---|
4583 | Name := Copy(ClassName,2,255);
|
---|
4584 | Tag := 0;
|
---|
4585 | If Designed Then Include(ComponentState,csReference);
|
---|
4586 | End;
|
---|
4587 |
|
---|
4588 |
|
---|
4589 | Constructor TComponent.Create(AOwner:TComponent);
|
---|
4590 | Begin
|
---|
4591 | //Inherited Create;
|
---|
4592 |
|
---|
4593 | If InsideWriteSCUAdr^ Then Include(ComponentState, csWriting);
|
---|
4594 |
|
---|
4595 | If AOwner Is TComponent Then AOwner.InsertComponent(Self);
|
---|
4596 |
|
---|
4597 | SetupComponent;
|
---|
4598 | End;
|
---|
4599 |
|
---|
4600 |
|
---|
4601 | Procedure SetupFormSCU(Form:TComponent);
|
---|
4602 | Begin
|
---|
4603 | If SCUPointer <> Nil Then Form.SetupSCU;
|
---|
4604 | End;
|
---|
4605 |
|
---|
4606 |
|
---|
4607 | Procedure TComponent.Notification(AComponent:TComponent;Operation:TOperation);
|
---|
4608 | Var I:LongInt;
|
---|
4609 | Begin
|
---|
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;
|
---|
4624 | End;
|
---|
4625 |
|
---|
4626 |
|
---|
4627 | Procedure TComponent.FreeNotification(AComponent:TComponent);
|
---|
4628 | Begin
|
---|
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;
|
---|
4636 | End;
|
---|
4637 |
|
---|
4638 |
|
---|
4639 | Function GetLanguages(Component:TComponent):PLanguageInfo;
|
---|
4640 | Begin
|
---|
4641 | Result:=Component.FLanguages;
|
---|
4642 | End;
|
---|
4643 |
|
---|
4644 | Procedure SetLanguages(Component:TComponent;Info:PLanguageInfo);
|
---|
4645 | Begin
|
---|
4646 | Component.FLanguages:=Info;
|
---|
4647 | End;
|
---|
4648 |
|
---|
4649 | Procedure FreeLanguage(Var LangComp:PLanguageComponent);
|
---|
4650 | Var NextLangComp:PLanguageComponent;
|
---|
4651 | Begin
|
---|
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;
|
---|
4662 | End;
|
---|
4663 |
|
---|
4664 | Destructor TComponent.Destroy;
|
---|
4665 | Var Meth,Last:PIDE_Methods;
|
---|
4666 | T:LongInt;
|
---|
4667 | Own:PIDE_OwnerList;
|
---|
4668 | I:LongInt;
|
---|
4669 | LangItem,NextLangItem:PLanguageItem;
|
---|
4670 | Begin
|
---|
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;
|
---|
4736 | End;
|
---|
4737 |
|
---|
4738 |
|
---|
4739 | Procedure TComponent.DestroyComponents;
|
---|
4740 | Var I:LongInt;
|
---|
4741 | Component:TComponent;
|
---|
4742 | Begin
|
---|
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;
|
---|
4757 | End;
|
---|
4758 |
|
---|
4759 | Function TComponent.GetComponentIndex:LongInt;
|
---|
4760 | Begin
|
---|
4761 | Result := -1;
|
---|
4762 | If FOwner = Nil Then Exit;
|
---|
4763 | If FOwner.FComponents = Nil Then Exit;
|
---|
4764 | Result := FOwner.FComponents.IndexOf(Self);
|
---|
4765 | End;
|
---|
4766 |
|
---|
4767 | Procedure TComponent.SetComponentIndex(Index:LongInt);
|
---|
4768 | Var I:LongInt;
|
---|
4769 | Begin
|
---|
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);
|
---|
4778 | End;
|
---|
4779 |
|
---|
4780 | Function TComponent.GetComponentCount:LongInt;
|
---|
4781 | Begin
|
---|
4782 | If FComponents=Nil Then Result:=0
|
---|
4783 | Else Result:=FComponents.Count;
|
---|
4784 | End;
|
---|
4785 |
|
---|
4786 | Function TComponent.GetComponent(AIndex:LongInt):TComponent;
|
---|
4787 | Begin
|
---|
4788 | If (FComponents=Nil) Or (AIndex<0) Or (AIndex>=FComponents.Count)
|
---|
4789 | Then Result:=Nil
|
---|
4790 | Else Result:=FComponents.Items[AIndex];
|
---|
4791 | End;
|
---|
4792 |
|
---|
4793 | Function TComponent.GetName:String;
|
---|
4794 | Begin
|
---|
4795 | If FName<>Nil Then Result:=FName^
|
---|
4796 | Else Result:='';
|
---|
4797 | End;
|
---|
4798 |
|
---|
4799 | Procedure TComponent.SetName(Const NewName:String);
|
---|
4800 | Begin
|
---|
4801 | AssignStr(FName,NewName);
|
---|
4802 | End;
|
---|
4803 |
|
---|
4804 | Function TComponent.GetUnitName:String;
|
---|
4805 | Begin
|
---|
4806 | If FUnitName <> Nil Then Result := FUnitName^
|
---|
4807 | Else Result := '';
|
---|
4808 | End;
|
---|
4809 |
|
---|
4810 | Function TComponent.GetTypeName:String;
|
---|
4811 | Begin
|
---|
4812 | If FTypeName <> Nil Then Result := FTypeName^
|
---|
4813 | Else Result := '';
|
---|
4814 | End;
|
---|
4815 |
|
---|
4816 | Procedure TComponent.SetTypeName(NewName:String);
|
---|
4817 | Begin
|
---|
4818 | AssignStr(FTypeName,NewName);
|
---|
4819 | End;
|
---|
4820 |
|
---|
4821 | Function TComponent.GetDesigned:Boolean;
|
---|
4822 | Begin
|
---|
4823 | Result := FComponentState * [csDesigning] <> [];
|
---|
4824 | End;
|
---|
4825 |
|
---|
4826 | Procedure TComponent.InsertComponent(AComponent:TComponent);
|
---|
4827 | Begin
|
---|
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);
|
---|
4835 | End;
|
---|
4836 |
|
---|
4837 | Procedure TComponent.RemoveComponent(AComponent:TComponent);
|
---|
4838 | Begin
|
---|
4839 | Notification(AComponent,opRemove);
|
---|
4840 | If FComponents = Nil Then Exit;
|
---|
4841 | FComponents.Remove(AComponent);
|
---|
4842 | End;
|
---|
4843 |
|
---|
4844 | Function TComponent.IndexOfComponent(AComponent:TComponent):LongInt;
|
---|
4845 | Begin
|
---|
4846 | Result := -1;
|
---|
4847 | If FComponents = Nil Then Exit;
|
---|
4848 | Result := FComponents.IndexOf(AComponent);
|
---|
4849 | End;
|
---|
4850 |
|
---|
4851 | Function TComponent.FindComponent(Const AName:String):TComponent;
|
---|
4852 | Var I:LongInt;
|
---|
4853 | Begin
|
---|
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;
|
---|
4861 | End;
|
---|
4862 |
|
---|
4863 |
|
---|
4864 | Procedure TComponent.SetDesigning(Value:Boolean);
|
---|
4865 | Var I:LongInt;
|
---|
4866 | Begin
|
---|
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);
|
---|
4871 | End;
|
---|
4872 |
|
---|
4873 |
|
---|
4874 | Procedure AddDesignerPopupEvent(AString:TStringList;Caption:String;Id:LongInt);
|
---|
4875 | Begin
|
---|
4876 | If AString Is TStringList Then AString.AddObject(Caption, TObject(Id));
|
---|
4877 | End;
|
---|
4878 |
|
---|
4879 |
|
---|
4880 | {event from the designer PopupMenu}
|
---|
4881 | {$HINTS OFF}
|
---|
4882 | Procedure TComponent.GetDesignerPopupEvents(AString:TStringList);
|
---|
4883 | Begin
|
---|
4884 | End;
|
---|
4885 |
|
---|
4886 | Procedure TComponent.DesignerPopupEvent(Id:LongInt);
|
---|
4887 | Begin
|
---|
4888 | End;
|
---|
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 |
|
---|
4906 | Const
|
---|
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 |
|
---|
4914 | Var
|
---|
4915 | NameTable:TList;
|
---|
4916 |
|
---|
4917 | Function NameTableAdd(P:PString):LongInt;
|
---|
4918 | Var T:LongInt;
|
---|
4919 | Ofs:LongInt;
|
---|
4920 | pp:PString;
|
---|
4921 | Begin
|
---|
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;
|
---|
4935 | End;
|
---|
4936 |
|
---|
4937 |
|
---|
4938 | Function SearchClassByName(Const Name:String):TComponentClass;
|
---|
4939 | Var T:LongInt;
|
---|
4940 | Comp:TComponentClass;
|
---|
4941 | S,s1:String;
|
---|
4942 | Begin
|
---|
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);
|
---|
4961 | End;
|
---|
4962 |
|
---|
4963 | Procedure RegisterClass(Const ComponentClass:TComponentClass);
|
---|
4964 | Var Comp:TComponentClass;
|
---|
4965 | t1:LongInt;
|
---|
4966 | Begin
|
---|
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);
|
---|
4974 | End;
|
---|
4975 |
|
---|
4976 | Function GetClass(Const ClassName:String):TComponentClass;
|
---|
4977 | Begin
|
---|
4978 | Result:=SearchClassByName(ClassName);
|
---|
4979 | End;
|
---|
4980 |
|
---|
4981 | Function FindClass(Const ClassName:String):TComponentClass;
|
---|
4982 | Begin
|
---|
4983 | Result:=GetClass(ClassName);
|
---|
4984 | If Result=Nil Then Raise EClassNotFound.Create(ClassName);
|
---|
4985 | End;
|
---|
4986 |
|
---|
4987 | Procedure UnRegisterClass(AClass:TComponentClass);
|
---|
4988 | Var t1:LongInt;
|
---|
4989 | Comp:TComponentClass;
|
---|
4990 | Label again;
|
---|
4991 | Begin
|
---|
4992 | again:
|
---|
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;
|
---|
5002 | End;
|
---|
5003 |
|
---|
5004 | Procedure UnRegisterClasses(Const AClasses:Array of TComponentClass);
|
---|
5005 | Var t:LongInt;
|
---|
5006 | Begin
|
---|
5007 | For t:=0 To High(AClasses) Do UnRegisterClass(AClasses[t]);
|
---|
5008 | End;
|
---|
5009 |
|
---|
5010 |
|
---|
5011 | Procedure RegisterClasses(Const ComponentClasses: Array Of TComponentClass);
|
---|
5012 | Var T,t1:LongInt;
|
---|
5013 | Comp,Comp1:TComponentClass;
|
---|
5014 | Label l1;
|
---|
5015 | Begin
|
---|
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);
|
---|
5026 | l1:
|
---|
5027 | End;
|
---|
5028 | End;
|
---|
5029 |
|
---|
5030 | {copies actual Value Of Property To Value.
|
---|
5031 | Value MUST be allocated With At least TypLen Bytes !}
|
---|
5032 | Function CallReadProp(Objekt:TObject;FuncAddr:Pointer;Typ:Byte;
|
---|
5033 | TypLen:LongInt;Value:Pointer):Boolean;
|
---|
5034 | Var
|
---|
5035 | FResult:LongInt;
|
---|
5036 | Func:Function(SelfObj:TObject):LongInt;
|
---|
5037 | FuncVar:Function(VarRef:Pointer;SelfObj:TObject):LongInt;
|
---|
5038 | Begin
|
---|
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;
|
---|
5093 | End;
|
---|
5094 |
|
---|
5095 | {copies actual Value Of Value To the Property.
|
---|
5096 | Value MUST be allocated With At least TypLen Bytes !}
|
---|
5097 | Function CallWriteProp(Objekt:TObject;ProcAddr:Pointer;Typ:Byte;
|
---|
5098 | TypLen:LongInt;Value:Pointer):Boolean;
|
---|
5099 | Var
|
---|
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;
|
---|
5106 | Begin
|
---|
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;
|
---|
5208 | End;
|
---|
5209 |
|
---|
5210 | Var PropertyNameTable:Pointer;
|
---|
5211 |
|
---|
5212 |
|
---|
5213 | Const 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 |
|
---|
5218 | Function WriteProperties(Stream:TMemoryStream;p1:Pointer;Objekt:TComponent;
|
---|
5219 | pParent:Pointer):Boolean; Forward;
|
---|
5220 |
|
---|
5221 |
|
---|
5222 | Function WritePropertyValues(Stream:TMemoryStream;P:Pointer;Objekt:TComponent;
|
---|
5223 | Namep:Pointer;ReferenceObjekt:TComponent):Boolean;
|
---|
5224 | Var 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;
|
---|
5241 | Label L,lll,lll1,ex,weiter;
|
---|
5242 | Begin
|
---|
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);
|
---|
5328 | lll:
|
---|
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;
|
---|
5349 | weiter:
|
---|
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;
|
---|
5416 | lll1:
|
---|
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
|
---|
5498 | L:
|
---|
5499 | Result:=True;
|
---|
5500 | ex:
|
---|
5501 | FreeMem(Value,TypLen);
|
---|
5502 | FreeMem(ReferenceValue,TypLen);
|
---|
5503 | End;
|
---|
5504 |
|
---|
5505 |
|
---|
5506 |
|
---|
5507 | Function WriteProperties(Stream:TMemoryStream;p1:Pointer;Objekt:TComponent;
|
---|
5508 | pParent:Pointer):Boolean;
|
---|
5509 | Var 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;
|
---|
5516 | Label L,ex;
|
---|
5517 | Begin
|
---|
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
|
---|
5535 | L:
|
---|
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;
|
---|
5585 | ex:
|
---|
5586 | Finally
|
---|
5587 | If ReferenceObjekt<>Nil Then ReferenceObjekt.Destroy;
|
---|
5588 | InsideWriteSCUAdr^:=False;
|
---|
5589 | End;
|
---|
5590 | End;
|
---|
5591 |
|
---|
5592 | Function WriteNameTable(Stream:TMemoryStream):Boolean;
|
---|
5593 | Var T:LongInt;
|
---|
5594 | pp:PString;
|
---|
5595 | Begin
|
---|
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;
|
---|
5606 | End;
|
---|
5607 |
|
---|
5608 |
|
---|
5609 | Function WriteObjectComponents(Stream:TMemoryStream;ResStream:TResourceStream;
|
---|
5610 | Objekt:TComponent):Boolean;
|
---|
5611 | Var Count:LongInt;
|
---|
5612 | PatchStreamPos:LongInt;
|
---|
5613 | CurStreamPos:LongInt;
|
---|
5614 | Begin
|
---|
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;
|
---|
5636 | End;
|
---|
5637 |
|
---|
5638 |
|
---|
5639 | {Write SCU information Of the Child Component}
|
---|
5640 | Procedure TComponent.WriteComponent(Child:TComponent);
|
---|
5641 | Const Zero:LongInt=0;
|
---|
5642 | Var pp,pp1,pParent1:^LongInt;
|
---|
5643 | tt:LongInt;
|
---|
5644 | B:Byte;
|
---|
5645 | Ok:Boolean;
|
---|
5646 | err:String[40];
|
---|
5647 | Label ex;
|
---|
5648 | Begin
|
---|
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;
|
---|
5720 | ex:
|
---|
5721 | If Not Ok Then
|
---|
5722 | Begin
|
---|
5723 | Raise ESCUError.Create('SCU write error for '+Child.ClassName+': '+err);
|
---|
5724 | End;
|
---|
5725 | End;
|
---|
5726 |
|
---|
5727 |
|
---|
5728 | Procedure TComponent.WriteToStream(SCUStream:TStream);
|
---|
5729 | Const Zero:LongInt=0;
|
---|
5730 | Var Stream:TMemoryStream;
|
---|
5731 | ResourceStream:TResourceStream;
|
---|
5732 | P,p1,pParent:^LongInt;
|
---|
5733 | FileDesc:TSCUFileFormat;
|
---|
5734 | Begin
|
---|
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 zerstrt??}
|
---|
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;
|
---|
5800 | End;
|
---|
5801 |
|
---|
5802 | Procedure TComponent.ReadSCU(Data:Pointer);
|
---|
5803 | Var
|
---|
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 |
|
---|
5874 | Label loadit,Next,skip;
|
---|
5875 | Begin
|
---|
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
|
---|
5986 | loadit:
|
---|
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);
|
---|
6057 | skip:
|
---|
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;
|
---|
6181 | Next:
|
---|
6182 | dummy:=dummy^.NextEntry;
|
---|
6183 | End;
|
---|
6184 |
|
---|
6185 | InsideDesigner:=OldInsideDesigner;
|
---|
6186 | End;
|
---|
6187 |
|
---|
6188 |
|
---|
6189 | Procedure TComponent.ReadFromStream(SCUStream:TStream);
|
---|
6190 | Var
|
---|
6191 | ClassMem,ClassPointer:^LongWord;
|
---|
6192 | OldPos:LongInt;
|
---|
6193 | OldInsideDesigner:Boolean;
|
---|
6194 | FileDesc:TSCUFileFormat;
|
---|
6195 | len:LongInt;
|
---|
6196 | NameTable:^LongWord;
|
---|
6197 | ResourceTable:^LongWord;
|
---|
6198 | Begin
|
---|
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;
|
---|
6234 | End;
|
---|
6235 |
|
---|
6236 |
|
---|
6237 | {$HINTS OFF}
|
---|
6238 | Procedure TComponent.GetChildren(Proc:TGetChildProc);
|
---|
6239 | Begin
|
---|
6240 | End;
|
---|
6241 | {$HINTS ON}
|
---|
6242 |
|
---|
6243 |
|
---|
6244 | Function TComponent.HasParent:Boolean;
|
---|
6245 | Begin
|
---|
6246 | Result := False;
|
---|
6247 | End;
|
---|
6248 |
|
---|
6249 | Function WritePropertiesToStream(FormList:TList):TMemoryStream;
|
---|
6250 | Const Zero:LongInt=0;
|
---|
6251 | bt:Byte=1;
|
---|
6252 | bf:Byte=0;
|
---|
6253 | Var 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 |
|
---|
6293 | Label err;
|
---|
6294 | Begin
|
---|
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
|
---|
6311 | err:
|
---|
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;
|
---|
6491 | End;
|
---|
6492 |
|
---|
6493 |
|
---|
6494 | Function WritePropertiesToFile(FileName:String;FormList:TList):Boolean;
|
---|
6495 | Var Stream:TMemoryStream;
|
---|
6496 | Begin
|
---|
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;
|
---|
6516 | End;
|
---|
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 |
|
---|
6534 | Procedure TStringSelectList.SetupComponent;
|
---|
6535 | Begin
|
---|
6536 | Inherited SetupComponent;
|
---|
6537 | FList.Create;
|
---|
6538 | FList.sorted:=True;
|
---|
6539 | Include(ComponentState, csDetail);
|
---|
6540 | End;
|
---|
6541 |
|
---|
6542 | Procedure TStringSelectList.SetStringItem(NewValue:String);
|
---|
6543 | Begin
|
---|
6544 | FSelected:=NewValue;
|
---|
6545 | End;
|
---|
6546 |
|
---|
6547 | Destructor TStringSelectList.Destroy;
|
---|
6548 | Begin
|
---|
6549 | FList.Destroy;
|
---|
6550 | FList := Nil;
|
---|
6551 | Inherited Destroy;
|
---|
6552 | End;
|
---|
6553 |
|
---|
6554 | Function TStringSelectList.GetItems:TStringList;
|
---|
6555 | Begin
|
---|
6556 | Result:=FList;
|
---|
6557 | End;
|
---|
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 |
|
---|
6573 | Destructor TBits.Destroy;
|
---|
6574 | Begin
|
---|
6575 | FreeMem(FBits, (FSize + 31) Shr 5);
|
---|
6576 | FBits := Nil;
|
---|
6577 | Inherited Destroy;
|
---|
6578 | End;
|
---|
6579 |
|
---|
6580 | Procedure TBits.Error;
|
---|
6581 | Begin
|
---|
6582 | Raise EBitsError.Create(LoadNLSStr(SEBitsErrorText));
|
---|
6583 | End;
|
---|
6584 |
|
---|
6585 | Function TBits.GetBit(Index: LongInt): Boolean;
|
---|
6586 | Var
|
---|
6587 | Place: Cardinal;
|
---|
6588 | Begin
|
---|
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;
|
---|
6593 | End;
|
---|
6594 |
|
---|
6595 | Function TBits.OpenBit: LongInt;
|
---|
6596 | Var
|
---|
6597 | I, J, K: LongInt;
|
---|
6598 | B: Cardinal;
|
---|
6599 | Begin
|
---|
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;
|
---|
6616 | End;
|
---|
6617 |
|
---|
6618 | Procedure TBits.SetBit(Index: LongInt; bit: Boolean);
|
---|
6619 | Var
|
---|
6620 | Place: Cardinal;
|
---|
6621 | Begin
|
---|
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;
|
---|
6627 | End;
|
---|
6628 |
|
---|
6629 | Procedure TBits.SetSize(NewSize: LongInt);
|
---|
6630 | Begin
|
---|
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;
|
---|
6635 | End;
|
---|
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 |
|
---|
6652 | Type
|
---|
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}
|
---|
6663 | Function TClassPropertyEditor.Execute(Var ClassToEdit:TObject):TClassPropertyEditorReturn;
|
---|
6664 | Begin
|
---|
6665 | Result:=peCancel; //Not Handled
|
---|
6666 | End;
|
---|
6667 | {$HINTS ON}
|
---|
6668 |
|
---|
6669 | Procedure AddPropertyEditor(OwnerClass:TClass;PropertyName:String;PropertyEditor:TPropertyEditorClass);
|
---|
6670 | Var T:LongInt;
|
---|
6671 | dummy:PPropertyEditClassItem;
|
---|
6672 | Begin
|
---|
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);
|
---|
6694 | End;
|
---|
6695 |
|
---|
6696 | Function CallPropertyEditor(Owner:TComponent;PropertyName:String;Var Value;ValueLen:LongInt;
|
---|
6697 | Var List:TStringList):TPropertyEditorReturn;
|
---|
6698 | Var T:LongInt;
|
---|
6699 | dummy:PPropertyEditClassItem;
|
---|
6700 | Editor:TPropertyEditor;
|
---|
6701 | S:String;
|
---|
6702 | Label go;
|
---|
6703 | Begin
|
---|
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
|
---|
6715 | go:
|
---|
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);
|
---|
6760 | End;
|
---|
6761 |
|
---|
6762 | Function PropertyEditorAvailable(OwnerClass:TClass;PropertyName:String):Boolean;
|
---|
6763 | Var T:LongInt;
|
---|
6764 | dummy:PPropertyEditClassItem;
|
---|
6765 | Begin
|
---|
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);
|
---|
6784 | End;
|
---|
6785 |
|
---|
6786 |
|
---|
6787 | Procedure AddClassPropertyEditor(ClassToEdit:TClass;PropertyEditor:TClassPropertyEditorClass);
|
---|
6788 | Var T:LongInt;
|
---|
6789 | dummy:PPropertyEditClassItem;
|
---|
6790 | Begin
|
---|
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);
|
---|
6808 | End;
|
---|
6809 |
|
---|
6810 | Function ClassPropertyEditorAvailable(ClassName:String):Boolean;
|
---|
6811 | Var
|
---|
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 |
|
---|
6839 | Label L,ex;
|
---|
6840 | Begin
|
---|
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;
|
---|
6853 | L:
|
---|
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 |
|
---|
6864 | ex:
|
---|
6865 | If @CallComplibClassPropertyEditorAvailable<>Nil Then
|
---|
6866 | Result:=Result Or CallCompLibClassPropertyEditorAvailable(ClassName);
|
---|
6867 | End;
|
---|
6868 |
|
---|
6869 | Function CallClassPropertyEditor(Var ClassToEdit:TObject):TClassPropertyEditorReturn;
|
---|
6870 | Var
|
---|
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;
|
---|
6902 | Begin
|
---|
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;
|
---|
6935 | End;
|
---|
6936 |
|
---|
6937 | ///////////////////////////////////////////////////////////////////////////
|
---|
6938 |
|
---|
6939 | Function GetExperts:TList;
|
---|
6940 | Begin
|
---|
6941 | Result:=LibExperts;
|
---|
6942 | End;
|
---|
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 |
|
---|
6960 | Procedure TThread.SetSuspended(NewValue:Boolean);
|
---|
6961 | Begin
|
---|
6962 | If NewValue Then Suspend
|
---|
6963 | Else Resume;
|
---|
6964 | End;
|
---|
6965 |
|
---|
6966 | Const
|
---|
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 |
|
---|
6981 | Procedure TThread.SetPriority(NewValue:TThreadPriority);
|
---|
6982 | Begin
|
---|
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}
|
---|
6990 | End;
|
---|
6991 |
|
---|
6992 | Procedure TThread.SyncTerminate;
|
---|
6993 | Begin
|
---|
6994 | FOnTerminate(Self);
|
---|
6995 | End;
|
---|
6996 |
|
---|
6997 | Procedure TThread.DoTerminate;
|
---|
6998 | Begin
|
---|
6999 | If FOnTerminate<>Nil Then Synchronize(SyncTerminate);
|
---|
7000 | End;
|
---|
7001 |
|
---|
7002 | Function ThreadLayer(Param:TThread):LongInt;
|
---|
7003 | {$IFDEF OS2}
|
---|
7004 | Var PAppHandle:LongWord;
|
---|
7005 | PAppQueueHandle:LongWord;
|
---|
7006 | {$ENDIF}
|
---|
7007 | Var FreeTerm:Boolean;
|
---|
7008 | Begin
|
---|
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);
|
---|
7035 | End;
|
---|
7036 |
|
---|
7037 |
|
---|
7038 | Const ThreadWindow:LongWord=0;
|
---|
7039 | WM_EXECUTEPROC=WM_USER+1;
|
---|
7040 |
|
---|
7041 | Var ThreadDefWndProc:Function(Win,Msg,para1,para2:LongWord):LongWord;APIENTRY;
|
---|
7042 | MsgProc:Procedure;
|
---|
7043 | ProcessProc:Procedure;
|
---|
7044 |
|
---|
7045 | Procedure TThread.MsgIdle;
|
---|
7046 | Begin
|
---|
7047 | ProcessProc;
|
---|
7048 | End;
|
---|
7049 |
|
---|
7050 | Function ThreadWndProc(Win:LongWord;Msg,para1,para2:LongWord):LongWord;APIENTRY;
|
---|
7051 | Var Thread:TThread;
|
---|
7052 | Begin
|
---|
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;
|
---|
7072 | End;
|
---|
7073 |
|
---|
7074 |
|
---|
7075 | Constructor TThread.ExtCreate(CreateSuspended:Boolean;StackSize:LongWord;Priority:TThreadPriority;
|
---|
7076 | Param:Pointer);
|
---|
7077 | Var Options:LongWord;
|
---|
7078 | Begin
|
---|
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);
|
---|
7117 | End;
|
---|
7118 |
|
---|
7119 | Constructor TThread.Create(CreateSuspended: Boolean);
|
---|
7120 | Begin
|
---|
7121 | TThread.ExtCreate(CreateSuspended,65535,tpNormal,Nil);
|
---|
7122 | End;
|
---|
7123 |
|
---|
7124 | Destructor TThread.Destroy;
|
---|
7125 | Begin
|
---|
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;
|
---|
7140 | End;
|
---|
7141 |
|
---|
7142 | Function TThread.WaitFor:LongInt;
|
---|
7143 | Var FreeIt:Boolean;
|
---|
7144 |
|
---|
7145 | Begin
|
---|
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;
|
---|
7154 | End;
|
---|
7155 |
|
---|
7156 | Procedure TThread.Terminate;
|
---|
7157 | Begin
|
---|
7158 | FTerminated:=True;
|
---|
7159 | End;
|
---|
7160 |
|
---|
7161 | Procedure TThread.Suspend;
|
---|
7162 | Begin
|
---|
7163 | FSuspended:=True;
|
---|
7164 | {$IFDEF OS2}
|
---|
7165 | DosSuspendThread(FHandle);
|
---|
7166 | {$ENDIF}
|
---|
7167 | {$IFDEF Win95}
|
---|
7168 | SuspendThread(FHandle);
|
---|
7169 | {$ENDIF}
|
---|
7170 | End;
|
---|
7171 |
|
---|
7172 | Procedure TThread.Resume;
|
---|
7173 | Begin
|
---|
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}
|
---|
7180 | End;
|
---|
7181 |
|
---|
7182 | //nach Mglichkeit nicht benutzen (statt dessen Terminate !), "abwrgen" des Threads
|
---|
7183 | //falls keine Mglichkeit zur Abfrage von "Terminated" besteht
|
---|
7184 | Procedure TThread.Kill;
|
---|
7185 | Var FreeTerm:Boolean;
|
---|
7186 | Begin
|
---|
7187 | Suspend;
|
---|
7188 | System.KillThread(FHandle);
|
---|
7189 | FreeTerm:=FreeOnTerminate;
|
---|
7190 | FFinished:=True;
|
---|
7191 | DoTerminate;
|
---|
7192 | If FreeTerm Then Self.Destroy;
|
---|
7193 | End;
|
---|
7194 |
|
---|
7195 | Procedure TThread.ProcessMsgs;
|
---|
7196 | Begin
|
---|
7197 | If ProcessProc<>Nil Then Synchronize(MsgIdle);
|
---|
7198 | End;
|
---|
7199 |
|
---|
7200 | Procedure TThread.Synchronize(method:TThreadMethod);
|
---|
7201 | Begin
|
---|
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;
|
---|
7215 | End;
|
---|
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 |
|
---|
7231 | Function TCollectionItem.GetIndex:LongInt;
|
---|
7232 | Begin
|
---|
7233 | If FCollection=Nil Then Result:=-1
|
---|
7234 | Else Result:=FCollection.FItems.IndexOf(Self);
|
---|
7235 | End;
|
---|
7236 |
|
---|
7237 | Procedure TCollectionItem.SetCollection(NewValue:TCollection);
|
---|
7238 | Begin
|
---|
7239 | If NewValue=FCollection Then Exit;
|
---|
7240 |
|
---|
7241 | If FCollection<>Nil Then FCollection.RemoveItem(Self);
|
---|
7242 | If NewValue<>Nil Then NewValue.InsertItem(Self);
|
---|
7243 | End;
|
---|
7244 |
|
---|
7245 | Procedure TCollectionItem.changed(AllItems:Boolean);
|
---|
7246 | Begin
|
---|
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;
|
---|
7252 | End;
|
---|
7253 |
|
---|
7254 | Procedure TCollectionItem.SetIndex(NewIndex:LongInt);
|
---|
7255 | Begin
|
---|
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;
|
---|
7262 | End;
|
---|
7263 |
|
---|
7264 | Constructor TCollectionItem.Create(ACollection: TCollection);
|
---|
7265 | Begin
|
---|
7266 | Inherited Create;
|
---|
7267 | collection:=ACollection;
|
---|
7268 | End;
|
---|
7269 |
|
---|
7270 | Destructor TCollectionItem.Destroy;
|
---|
7271 | Begin
|
---|
7272 | collection:=Nil;
|
---|
7273 | Inherited Destroy;
|
---|
7274 | End;
|
---|
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 |
|
---|
7291 | Function TCollection.GetCount:LongInt;
|
---|
7292 | Begin
|
---|
7293 | Result:=FItems.Count;
|
---|
7294 | End;
|
---|
7295 |
|
---|
7296 | Procedure TCollection.InsertItem(Item:TCollectionItem);
|
---|
7297 | Begin
|
---|
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;
|
---|
7305 | End;
|
---|
7306 |
|
---|
7307 | Procedure TCollection.RemoveItem(Item:TCollectionItem);
|
---|
7308 | Begin
|
---|
7309 | FItems.Remove(Item);
|
---|
7310 | Item.FCollection:=Nil;
|
---|
7311 | changed;
|
---|
7312 | End;
|
---|
7313 |
|
---|
7314 | Procedure TCollection.changed;
|
---|
7315 | Begin
|
---|
7316 | If FUpdateCount=0 Then Update(Nil);
|
---|
7317 | End;
|
---|
7318 |
|
---|
7319 | Function TCollection.GetItem(Index:LongInt):TCollectionItem;
|
---|
7320 | Begin
|
---|
7321 | Result:=TCollectionItem(FItems[Index]);
|
---|
7322 | End;
|
---|
7323 |
|
---|
7324 | Procedure TCollection.SetItem(Index:LongInt;Value:TCollectionItem);
|
---|
7325 | Var dummy:TCollectionItem;
|
---|
7326 | Begin
|
---|
7327 | dummy:=TCollectionItem(FItems[Index]);
|
---|
7328 | dummy.Assign(Value);
|
---|
7329 | End;
|
---|
7330 |
|
---|
7331 | {$HINTS OFF}
|
---|
7332 | Procedure TCollection.Update(Item:TCollectionItem);
|
---|
7333 | Begin
|
---|
7334 | End;
|
---|
7335 | {$HINTS ON}
|
---|
7336 |
|
---|
7337 | Procedure TCollection.SetupComponent;
|
---|
7338 | Begin
|
---|
7339 | Inherited SetupComponent;
|
---|
7340 |
|
---|
7341 | Name:='Collection';
|
---|
7342 | FItemClass:=TCollectionItem;
|
---|
7343 | FItems.Create;
|
---|
7344 | Include(ComponentState,csDetail);
|
---|
7345 | End;
|
---|
7346 |
|
---|
7347 | Destructor TCollection.Destroy;
|
---|
7348 | Begin
|
---|
7349 | FUpdateCount:=1;
|
---|
7350 | Clear;
|
---|
7351 | FItems.Destroy;
|
---|
7352 |
|
---|
7353 | Inherited Destroy;
|
---|
7354 | End;
|
---|
7355 |
|
---|
7356 | Function TCollection.Add:TCollectionItem;
|
---|
7357 | Begin
|
---|
7358 | Result:=FItemClass.Create(Self);
|
---|
7359 | End;
|
---|
7360 |
|
---|
7361 | Function TCollection.Insert(Index:longint):TCollectionItem;
|
---|
7362 | begin
|
---|
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;
|
---|
7367 | end;
|
---|
7368 |
|
---|
7369 | Procedure TCollection.Swap(Index1,Index2:longint);
|
---|
7370 | var
|
---|
7371 | Item: TCollectionItem;
|
---|
7372 | begin
|
---|
7373 | Item := FItems[ Index1 ];
|
---|
7374 | FItems[ Index1 ] := FItems[ Index2 ];
|
---|
7375 | FItems[ Index2 ] := Item;
|
---|
7376 | end;
|
---|
7377 |
|
---|
7378 | Procedure TCollection.Assign(Source:TCollection);
|
---|
7379 | Var dummy:TCollectionItem;
|
---|
7380 | T:LongInt;
|
---|
7381 | Begin
|
---|
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;
|
---|
7395 | End;
|
---|
7396 |
|
---|
7397 | Procedure TCollection.BeginUpdate;
|
---|
7398 | Begin
|
---|
7399 | Inc(FUpdateCount);
|
---|
7400 | End;
|
---|
7401 |
|
---|
7402 | Procedure TCollection.EndUpdate;
|
---|
7403 | Begin
|
---|
7404 | Dec(FUpdateCount);
|
---|
7405 | changed;
|
---|
7406 | End;
|
---|
7407 |
|
---|
7408 | Procedure TCollection.Clear;
|
---|
7409 | Var T:LongInt;
|
---|
7410 | dummy:TCollectionItem;
|
---|
7411 | Begin
|
---|
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;
|
---|
7425 | End;
|
---|
7426 |
|
---|
7427 | Begin
|
---|
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;
|
---|
7442 | End.
|
---|