source: cprs/branches/tmg-cprs/CPRS-Lib/ORFn.pas@ 1806

Last change on this file since 1806 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 59.0 KB
Line 
1unit ORFn;
2
3{$OPTIMIZATION OFF}
4
5interface // --------------------------------------------------------------------------------
6
7uses SysUtils, Windows, Messages, Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Forms,
8 Graphics, Menus, RichEdit;
9
10const
11 U = '^';
12 CRLF = #13#10;
13 BOOLCHAR: array[Boolean] of Char = ('0', '1');
14 UM_STATUSTEXT = (WM_USER + 302); // used to send update status msg to main form
15 COLOR_CREAM = $F0FBFF;
16
17type
18 TFMDateTime = Double;
19 TORIdleCallProc = procedure(Msg: string);
20
21{ Date/Time functions }
22function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
23function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
24function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
25function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
26function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
27function IsFMDateTime(x: string): Boolean;
28function MakeFMDateTime(const AString: string): TFMDateTime;
29procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
30 PieceNum: Integer; KeepBad: boolean = FALSE);
31
32{ Numeric functions }
33function HigherOf(i, j: Integer): Integer;
34function LowerOf(i, j: Integer): Integer;
35function StrToFloatDef(const S: string; ADefault: Extended): Extended;
36
37{ String functions }
38function CharAt(const x: string; APos: Integer): Char;
39function ContainsAlpha(const x: string): Boolean;
40function ContainsVisibleChar(const x: string): Boolean;
41function ConvertSpecialStrings(const x: string): String;
42function CRCForFile(AFileName: string): DWORD;
43function CRCForStrings(AStringList: TStrings): DWORD;
44procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
45function ExtractInteger(x: string): Integer;
46function ExtractFloat(x: string): Extended;
47function ExtractDefault(Src: TStrings; const Section: string): string;
48procedure ExtractItems(Dest, Src: TStrings; const Section: string);
49procedure ExtractText(Dest, Src: TStrings; const Section: string);
50function FilteredString(const x: string; ATabWidth: Integer = 8): string;
51procedure InvertStringList(AList: TStringList);
52procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
53function MixedCase(const x: string): string;
54procedure MixedCaseList(AList: TStrings);
55procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
56function Piece(const S: string; Delim: char; PieceNum: Integer): string; overload; //kt 8/09 added 'overload'
57function Piece(const S: string; Delim: string; PieceNum: Integer): string; overload; //kt 8/09
58function PieceNCS(const S: string; Delim: string; PieceNum: Integer): string; overload; //kt 8/09
59function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string; overload; //kt 8/09 added 'overload'
60function Pieces(const S: string; Delim: string; PieceStart,PieceEnd: Integer): string; overload; //kt 8/09 added
61function PiecesNCS(const S: string; Delim: string; PieceStart,PieceEnd: Integer): string; //kt 8/09 added
62function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
63 char = '^'; CaseInsensitive: boolean = FALSE): integer;
64procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
65function ReverseStr(const x: string): string;
66procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
67procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
68 FromString: string);
69procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
70function DelimCount(const Str, Delim: string): integer;
71procedure QuickCopy(AFrom, ATo: TObject);
72function ValidFileName(const InitialFileName: string): string;
73
74{ Display functions }
75procedure ForceInsideWorkArea( var Rect: TRect);
76//procedure ClearControl(AControl: TControl);
77function InfoBox(const Text, Caption: string; Flags: Word): Integer;
78procedure LimitEditWidth(AControl: TWinControl; NumChars: Integer);
79function MainFont: TFont;
80function MainFontSize: Integer;
81function MainFontWidth: Integer;
82function MainFontHeight: Integer;
83function BaseFont: TFont;
84procedure RedrawSuspend(AHandle: HWnd);
85procedure RedrawActivate(AHandle: HWnd);
86//procedure ResetControl(AControl: TControl);
87procedure ResetSelectedForList(AListBox: TListBox);
88procedure ResizeFormToFont(AForm: TForm);
89procedure ResizeAnchoredFormToFont( AForm: TForm);
90function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
91function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
92procedure ResizeToFont(FontSize: Integer; var W, H: Integer);
93procedure SetEqualTabStops(AControl: TControl; TabWidth: Integer = 8);
94procedure StatusText(const S: string);
95function ShowMsgOn(AnExpression: Boolean; const AMsg, ACaption: string): Boolean;
96function TextWidthByFont(AFontHandle: THandle; const x: string): Integer;
97function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
98function WrappedTextHeightByFont(Canvas: TCanvas; NewFont: TFont; ItemText: string; var ARect: TRect): integer;
99function NumCharsFitInWidth(AFontHandle: THandle; const x: string; const MaxLen: integer): Integer;
100function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
101procedure ReformatMemoParagraph(AMemo: TCustomMemo);
102function ReadOnlyColor: TColor;
103
104{ ListBox Grid functions }
105procedure ListGridDrawCell(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
106 const x: string; WordWrap: Boolean);
107procedure ListGridDrawLines(AListBox: TListBox; AHeader: THeaderControl; Index: Integer;
108 State: TOwnerDrawState);
109function ListGridRowHeight(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
110 const x: string): Integer;
111
112{ Misc functions }
113{ You MUST pass an address to an object variable to get KillObj to work }
114procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
115
116{ do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet }
117procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
118procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
119procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
120function TabIsPressed : Boolean;
121function ShiftTabIsPressed : Boolean;
122
123implementation // ---------------------------------------------------------------------------
124
125uses
126 StrUtils, //kt 8/09
127 ORCtrls, Grids, Chart, CheckLst;
128
129const
130 { names of months used by FormatFMDateTime }
131 MONTH_NAMES_SHORT: array[1..12] of string[3] =
132 ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
133 MONTH_NAMES_LONG: array[1..12] of string[9] =
134 ('January','February','March','April','May','June','July','August','September','October',
135 'November', 'December');
136
137 // ConvertSpecialStrings arrays
138 SearchChars: array[0..7] of String = (' Ii ',' Iii ',' Iv ',' Vi ',' Vii ',' Viii ',' Ix ','-Va');
139 ReplaceChars: array[0..7] of String = (' II ',' III ',' IV ',' VI ',' VII ',' VIII ',' IX ','-VA');
140
141 { table for calculating CRC values (DWORD is Integer in Delphi 3, Cardinal in Delphi 4}
142 CRC32_TABLE: array[0..255] of DWORD =
143 ($0, $77073096, $EE0E612C, $990951BA, $76DC419, $706AF48F, $E963A535, $9E6495A3,
144 $EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $9B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
145 $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
146 $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
147 $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
148 $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
149 $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
150 $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
151 $76DC4190, $1DB7106, $98D220BC, $EFD5102A, $71B18589, $6B6B51F, $9FBFE4A5, $E8B8D433,
152 $7807C9A2, $F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $86D3D2D, $91646C97, $E6635C01,
153 $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
154 $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
155 $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
156 $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
157 $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
158 $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
159 $EDB88320, $9ABFB3B6, $3B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $4DB2615, $73DC1683,
160 $E3630B12, $94643B84, $D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $A00AE27, $7D079EB1,
161 $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
162 $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
163 $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
164 $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
165 $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
166 $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
167 $9B64C2B0, $EC63F226, $756AA39C, $26D930A, $9C0906A9, $EB0E363F, $72076785, $5005713,
168 $95BF4A82, $E2B87A14, $7BB12BAE, $CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $BDBDF21,
169 $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
170 $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
171 $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
172 $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
173 $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
174 $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
175
176 {Properties assigned to BaseFont}
177 BaseFontSize = 8;
178 BaseFontName = 'MS Sans Serif';
179var
180 FBaseFont: TFont;
181type
182 EFMDateTimeError = class(Exception);
183
184 {TFontControl is an artifact used for font resizing. Do not add virtual
185 methods or class variables to it!}
186 TFontControl = class(TControl)
187 public
188 property Font;
189 property ParentFont;
190 end;
191
192{ Date/Time functions }
193
194function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
195{ converts a Delphi date/time type to a Fileman date/time (type double) }
196var
197 y, m, d, h, n, s, l: Word;
198 DatePart,TimePart: Integer;
199begin
200 DecodeDate(ADateTime, y, m, d);
201 DecodeTime(ADateTime, h, n, s, l);
202 DatePart := ((y-1700)*10000) + (m*100) + d;
203 TimePart := (h*10000) + (n*100) + s;
204 Result := DatePart + (TimePart / 1000000);
205end;
206
207function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
208{ converts a Fileman date/time (type double) to a Delphi date/time }
209var
210 ADate, ATime: TDateTime;
211 DatePart, TimePart: string;
212begin
213 DatePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 1);
214 TimePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 2) + '000000';
215 if Length(DatePart) <> 7 then raise EFMDateTimeError.Create('Invalid Fileman Date');
216 if Copy(TimePart, 1, 2) = '24' then TimePart := '23595959';
217 ADate := EncodeDate(StrToInt(Copy(DatePart, 1, 3)) + 1700,
218 StrToInt(Copy(DatePart, 4, 2)),
219 StrToInt(Copy(DatePart, 6, 2)));
220 ATime := EncodeTime(StrToInt(Copy(TimePart, 1, 2)),
221 StrToInt(Copy(TimePart, 3, 2)),
222 StrToInt(Copy(TimePart, 5, 2)), 0);
223 Result := ADate + ATime;
224end;
225
226function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
227{ adds / subtracts days from a Fileman date/time and returns the offset Fileman date/time }
228var
229 Julian: TDateTime;
230begin
231 Julian := FMDateTimeToDateTime(ADateTime);
232 Result := DateTimeToFMDateTime(Julian + DaysDiff);
233end;
234
235function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
236{ formats a Fileman Date/Time using (mostly) the same format string as Delphi FormatDateTime }
237var
238 x: string;
239 y, m, d, h, n, s: Integer;
240
241 function TrimFormatCount: Integer;
242 { delete repeating characters and count how many were deleted }
243 var
244 c: Char;
245 begin
246 Result := 0;
247 c := AFormat[1];
248 repeat
249 Delete(AFormat, 1, 1);
250 Inc(Result);
251 until CharAt(AFormat, 1) <> c;
252 end;
253
254begin {FormatFMDateTime}
255 Result := '';
256 if not (ADateTime > 0) then Exit;
257 x := FloatToStrF(ADateTime, ffFixed, 15, 6) + '0000000';
258 y := StrToIntDef(Copy(x, 1, 3), 0) + 1700;
259 m := StrToIntDef(Copy(x, 4, 2), 0);
260 d := StrToIntDef(Copy(x, 6, 2), 0);
261 h := StrToIntDef(Copy(x, 9, 2), 0);
262 n := StrToIntDef(Copy(x, 11, 2), 0);
263 s := StrToIntDef(Copy(x, 13, 2), 0);
264 while Length(AFormat) > 0 do
265 case UpCase(AFormat[1]) of
266 '"': begin // literal
267 Delete(AFormat, 1, 1);
268 while not (CharAt(AFormat, 1) in [#0, '"']) do
269 begin
270 Result := Result + AFormat[1];
271 Delete(AFormat, 1, 1);
272 end;
273 if CharAt(AFormat, 1) = '"' then Delete(AFormat, 1, 1);
274 end;
275 'D': case TrimFormatCount of // day/date
276 1: if d > 0 then Result := Result + IntToStr(d);
277 2: if d > 0 then Result := Result + FormatFloat('00', d);
278 end;
279 'H': case TrimFormatCount of // hour
280 1: Result := Result + IntToStr(h);
281 2: Result := Result + FormatFloat('00', h);
282 end;
283 'M': case TrimFormatCount of // month
284 1: if m > 0 then Result := Result + IntToStr(m);
285 2: if m > 0 then Result := Result + FormatFloat('00', m);
286 3: if m in [1..12] then Result := Result + MONTH_NAMES_SHORT[m];
287 4: if m in [1..12] then Result := Result + MONTH_NAMES_LONG[m];
288 end;
289 'N': case TrimFormatCount of // minute
290 1: Result := Result + IntToStr(n);
291 2: Result := Result + FormatFloat('00', n);
292 end;
293 'S': case TrimFormatCount of // second
294 1: Result := Result + IntToStr(s);
295 2: Result := Result + FormatFloat('00', s);
296 end;
297 'Y': case TrimFormatCount of // year
298 2: if y > 0 then Result := Result + Copy(IntToStr(y), 3, 2);
299 4: if y > 0 then Result := Result + IntToStr(y);
300 end;
301 else begin // other
302 Result := Result + AFormat[1];
303 Delete(AFormat, 1, 1);
304 end;
305 end; {case}
306end; {FormatFMDateTime}
307
308function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
309var
310 FMDateTime: TFMDateTime;
311begin
312 Result := ADateTime;
313 if IsFMDateTime(ADateTime) then
314 begin
315 FMDateTime := MakeFMDateTime(ADateTime);
316 Result := FormatFMDateTime(AFormat, FMDateTime);
317 end;
318end;
319
320function IsFMDateTime(x: string): Boolean;
321var
322 i: Integer;
323begin
324 Result := False;
325 if Length(x) < 7 then Exit;
326 for i := 1 to 7 do if not (x[i] in ['0'..'9']) then Exit;
327 if (Length(x) > 7) and (x[8] <> '.') then Exit;
328 if (Length(x) > 8) and not (x[9] in ['0'..'9']) then Exit;
329 Result := True;
330end;
331
332function MakeFMDateTime(const AString: string): TFMDateTime;
333begin
334 Result := -1;
335 if (Length(AString) > 0) and IsFMDateTime(AString) then Result := StrToFloat(AString);
336end;
337
338procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
339 PieceNum: Integer; KeepBad: boolean = FALSE);
340var
341 i: Integer;
342 s, x, x1: string;
343
344begin
345 for i := 0 to AList.Count - 1 do
346 begin
347 s := AList[i];
348 x := Piece(s, ADelim, PieceNum);
349 if Length(x) > 0 then
350 begin
351 x1 := FormatFMDateTime(AFormat, MakeFMDateTime(x));
352 if(x1 <> '') or (not KeepBad) then
353 x := x1;
354 end;
355 SetPiece(s, ADelim, PieceNum, x);
356 AList[i] := s;
357 end;
358end;
359
360{ Numeric functions }
361
362function HigherOf(i, j: Integer): Integer;
363{ returns the greater of two integers }
364begin
365 Result := i;
366 if j > i then Result := j;
367end;
368
369function LowerOf(i, j: Integer): Integer;
370{ returns the lesser of two integers }
371begin
372 Result := i;
373 if j < i then Result := j;
374end;
375
376function StrToFloatDef(const S: string; ADefault: Extended): Extended;
377begin
378 if not TextToFloat(PChar(S), Result, fvExtended) then
379 Result := ADefault;
380end;
381
382{ String functions }
383
384function CharAt(const x: string; APos: Integer): Char;
385{ returns a character at a given position in a string or the null character if past the end }
386begin
387 if Length(x) < APos then Result := #0 else Result := x[APos];
388end;
389
390function ContainsAlpha(const x: string): Boolean;
391{ returns true if the string contains any alpha characters }
392var
393 i: Integer;
394begin
395 Result := False;
396 for i := 1 to Length(x) do if x[i] in ['A'..'Z','a'..'z'] then
397 begin
398 Result := True;
399 break;
400 end;
401end;
402
403function ContainsVisibleChar(const x: string): Boolean;
404{ returns true if the string contains any printable characters }
405var
406 i: Integer;
407begin
408 Result := False;
409 for i := 1 to Length(x) do if x[i] in ['!'..'~'] then // ordinal values 33..126
410 begin
411 Result := True;
412 break;
413 end;
414end;
415
416function ConvertSpecialStrings(const x: string): string;
417var i : Integer;
418begin
419 for i := 0 to Length(SearchChars)-1 do
420 begin
421 Result := StringReplace(Result,SearchChars[i], ReplaceChars[i],[rfReplaceAll]);
422 end;
423end;
424
425function UpdateCrc32(Value: DWORD; var Buffer: array of Byte; Count: Integer): DWORD;
426var
427 i: integer;
428begin
429 Result:=Value;
430 for i := 0 to Pred(Count) do
431 Result := ((Result shr 8) and $00FFFFFF) xor
432 CRC32_TABLE[(Result xor Buffer[i]) and $000000FF];
433end;
434
435function CRCForFile(AFileName: string): DWORD;
436const
437 BUF_SIZE = 16383;
438type
439 TBuffer = array[0..BUF_SIZE] of Byte;
440var
441 Buffer: Pointer;
442 AHandle, BytesRead: Integer;
443begin
444 Result:=$FFFFFFFF;
445 GetMem(Buffer, BUF_SIZE);
446 AHandle := FileOpen(AFileName, fmShareDenyWrite);
447 repeat
448 BytesRead := FileRead(AHandle, Buffer^, BUF_SIZE);
449 Result := UpdateCrc32(Result, TBuffer(Buffer^), BytesRead);
450 until BytesRead <> BUF_SIZE;
451 FileClose(AHandle);
452 FreeMem(Buffer);
453 Result := not Result;
454end;
455
456function CRCForStrings(AStringList: TStrings): DWORD;
457{ returns a cyclic redundancy check for a list of strings }
458var
459 i, j: Integer;
460begin
461 Result:=$FFFFFFFF;
462 for i := 0 to AStringList.Count - 1 do
463 for j := 1 to Length(AStringList[i]) do
464 Result:=((Result shr 8) and $00FFFFFF) xor
465 CRC32_TABLE[(Result xor Ord(AStringList[i][j])) and $000000FF];
466end;
467
468function FilteredString(const x: string; ATabWidth: Integer = 8): string;
469var
470 i, j: Integer;
471begin
472 Result := '';
473 for i := 1 to Length(x) do
474 case x[i] of
475 #9: for j := 1 to (ATabWidth - (Length(Result) mod ATabWidth)) do
476 Result := Result + ' ';
477 #32..#127: Result := Result + x[i];
478 #128..#159: Result := Result + '?';
479 #10,#13,#160: Result := Result + ' ';
480 #161..#255: Result := Result + x[i];
481 end;
482 if Copy(Result, Length(Result), 1) = ' ' then Result := TrimRight(Result) + ' ';
483end;
484
485procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
486var
487 i, j, k: Integer;
488 x, y: string;
489begin
490 with AList do for i := 0 to Count - 1 do
491 begin
492 x := Strings[i];
493 y := '';
494 for j := 1 to Length(x) do
495 case x[j] of
496 #9: for k := 1 to (ATabWidth - (Length(y) mod ATabWidth)) do y := y + ' ';
497 #32..#127: y := y + x[j];
498 #128..#159: y := y + '?';
499 #160: y := y + ' ';
500 #161..#255: y := y + x[j];
501 end;
502 if Copy(y, Length(y), 1) = ' ' then y := TrimRight(y) + ' ';
503 Strings[i] := y;
504 //Strings[i] := TrimRight(y) + ' ';
505 end;
506end;
507
508function ExtractInteger(x: string): Integer;
509{ strips leading & trailing alphas to return an integer }
510var
511 i: Integer;
512begin
513 while (Length(x) > 0) and not (x[1] in ['0'..'9']) do Delete(x, 1, 1);
514 for i := 1 to Length(x) do if not (x[i] in ['0'..'9']) then break;
515 Result := StrToIntDef(Copy(x, 1, i - 1), 0);
516end;
517
518function ExtractFloat(x: string): Extended;
519{ strips leading & trailing alphas to return a float }
520var
521 i: Integer;
522begin
523 while (Length(x) > 0) and not (x[1] in ['0'..'9', '.']) do Delete(x, 1, 1);
524 for i := 1 to Length(x) do if not (x[i] in ['0'..'9','.']) then break;
525 Result := StrToFloatDef(Copy(x, 1, i - 1), 0);
526end;
527
528function ExtractDefault(Src: TStrings; const Section: string): string;
529var
530 i: Integer;
531begin
532 Result := '';
533 i := -1;
534 repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
535 Inc(i);
536 if (i < Src.Count) and (Src[i][1] <> '~') then repeat
537 if Src[i][1] = 'd' then Result := Copy(Src[i], 2, MaxInt);
538 Inc(i);
539 until (i = Src.Count) or (Src[i][1] = '~') or (Length(Result) > 0);
540end;
541
542procedure ExtractItems(Dest, Src: TStrings; const Section: string);
543var
544 i: Integer;
545begin
546 i := -1;
547 repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
548 Inc(i);
549 if (i < Src.Count) and (Src[i][1] <> '~') then repeat
550 if Src[i][1] = 'i' then Dest.Add(Copy(Src[i], 2, MaxInt));
551 Inc(i);
552 until (i = Src.Count) or (Src[i][1] = '~');
553end;
554
555procedure ExtractText(Dest, Src: TStrings; const Section: string);
556var
557 i: Integer;
558begin
559 i := -1;
560 repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
561 Inc(i);
562 if (i < Src.Count) and (Src[i][1] <> '~') then repeat
563 if Src[i][1] = 't' then Dest.Add(Copy(Src[i], 2, MaxInt));
564 Inc(i);
565 until (i = Src.Count) or (Src[i][1] = '~');
566end;
567
568procedure InvertStringList(AList: TStringList);
569var
570 i: Integer;
571begin
572 with AList do for i := 0 to ((Count div 2) - 1) do Exchange(i, Count - i - 1);
573end;
574
575function MixedCase(const x: string): string;
576var
577 i: integer;
578begin
579 Result := x;
580 for i := 2 to Length(x) do
581 if (not (x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
582 // save line if (not (x[i-1] in [' ','''',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
583 then Result[i] := Chr(Ord(x[i]) + 32)
584 else if ((x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['a'..'z'])
585 then Result[i] := Chr(Ord(x[i]) - 32);
586 //Call added to satisfy the need for special string handling(Roman Numerals II-XI) GRE-06/02
587 Result := ConvertSpecialStrings(x);
588end;
589
590procedure MixedCaseList(AList: TStrings);
591var
592 i: integer;
593begin
594 for i := 0 to (AList.Count - 1) do AList[i] := MixedCase(AList[i]);
595end;
596
597procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
598var
599 i: Integer;
600 x, p: string;
601begin
602 for i := 0 to (AList.Count - 1) do
603 begin
604 x := AList[i];
605 p := MixedCase(Piece(x, ADelim, PieceNum));
606 SetPiece(x, ADelim, PieceNum, p);
607 AList[i] := x;
608 end;
609end;
610
611function Piece(const S: string; Delim: char; PieceNum: Integer): string; overload; //kt 8/09 added 'overload;'
612{ returns the Nth piece (PieceNum) of a string delimited by Delim }
613var
614 i: Integer;
615 Strt, Next: PChar;
616begin
617 i := 1;
618 Strt := PChar(S);
619 Next := StrScan(Strt, Delim);
620 while (i < PieceNum) and (Next <> nil) do
621 begin
622 Inc(i);
623 Strt := Next + 1;
624 Next := StrScan(Strt, Delim);
625 end;
626 if Next = nil then Next := StrEnd(Strt);
627 if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
628end;
629
630function PieceNCS(const S: string; Delim: string; PieceNum: Integer): string; overload;
631//kt 8/09 Name means Piece-Not-Case-Sensitive, meaning match for Delim is not case sensitive.
632//kt 8/09 Added entire function
633var tempS : string;
634begin
635 tempS := AnsiReplaceText(S,Delim,UpperCase(Delim));
636 Result := Piece(tempS,UpperCase(Delim),PieceNum);
637end;
638
639function Piece(const S: string; Delim: string; PieceNum: Integer): string; overload;
640//kt 8/09 Added entire function
641var Remainder : String;
642 PieceLen,p : integer;
643begin
644 Remainder := S;
645 Result := '';
646 PieceLen := Length(Delim);
647 while (PieceNum > 0) and (Length(Remainder) > 0) do begin
648 p := Pos(Delim,Remainder);
649 if p=0 then p := length(Remainder)+1;
650 Result := MidStr(Remainder,1,p-1);
651 Remainder := MidStr(Remainder,p+PieceLen,9999);
652 Dec(PieceNum);
653 end;
654end;
655
656function Pieces(const S: string; Delim: string; PieceStart,PieceEnd: Integer): string; overload;
657//kt 8/09 Added entire function
658var Remainder : String;
659 PieceNum : integer;
660 PieceLen,p : integer;
661begin
662 Remainder := S;
663 Result := '';
664 PieceLen := Length(Delim);
665 PieceNum := PieceStart;
666 while (PieceNum > 1) and (Length(Remainder) > 0) do begin
667 p := Pos(Delim,Remainder);
668 if p=0 then p := length(Remainder)+1;
669 Result := MidStr(Remainder,1,p-1);
670 Remainder := MidStr(Remainder,p+PieceLen,9999);
671 Dec(PieceNum);
672 end;
673 PieceNum := PieceEnd-PieceStart+1;
674 Result := '';
675 while (PieceNum > 0) and (Length(Remainder) > 0) do begin
676 p := Pos(Delim,Remainder);
677 if p=0 then p := length(Remainder)+1;
678 if Result <> '' then Result := Result + Delim;
679 Result := Result + MidStr(Remainder,1,p-1);
680 Remainder := MidStr(Remainder,p+PieceLen,9999);
681 Dec(PieceNum);
682 end;
683end;
684
685function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
686{ returns several contiguous pieces }
687var
688 PieceNum: Integer;
689begin
690 Result := '';
691 for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
692 if Length(Result) > 0 then Delete(Result, Length(Result), 1);
693end;
694
695function PiecesNCS(const S: string; Delim: string; PieceStart,PieceEnd: Integer): string;
696//kt 8/09 Name means Pieces-Not-Case-Sensitive, meaning match for Delim is not case sensitive.
697//kt 8/09 Added entire function
698var tempS : string;
699begin
700 tempS := AnsiReplaceText(S,Delim,UpperCase(Delim));
701 Result := Pieces(tempS,UpperCase(Delim),PieceStart,PieceEnd);
702end;
703
704function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
705 char = '^'; CaseInsensitive: boolean = FALSE): integer;
706var
707 i: integer;
708
709begin
710 i := 0;
711 Result := 0;
712 while i <= high(Pieces) do
713 begin
714 if(CaseInsensitive) then
715 Result := CompareText(Piece(P1, Delim, Pieces[i]),
716 Piece(P2, Delim, Pieces[i]))
717 else
718 Result := CompareStr(Piece(P1, Delim, Pieces[i]),
719 Piece(P2, Delim, Pieces[i]));
720 if(Result = 0) then
721 inc(i)
722 else
723 break;
724 end;
725end;
726
727procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
728{ adds each piece to a TStrings list, the list is cleared first }
729var
730 APiece: string;
731begin
732 AList.Clear;
733 while Length(x) > 0 do
734 begin
735 APiece := Piece(x, ADelim, 1);
736 AList.Add(APiece);
737 Delete(x, 1, Length(APiece) + 1);
738 end;
739end;
740
741function ReverseStr(const x: string): string;
742var
743 i, j: Integer;
744begin
745 SetString(Result, PChar(x), Length(x));
746 i := 0;
747 for j := Length(x) downto 1 do
748 begin
749 Inc(i);
750 Result[i] := x[j];
751 end;
752end;
753
754procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
755{ sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
756var
757 i: Integer;
758 Strt, Next: PChar;
759begin
760 i := 1;
761 Strt := PChar(x);
762 Next := StrScan(Strt, Delim);
763 while (i < PieceNum) and (Next <> nil) do
764 begin
765 Inc(i);
766 Strt := Next + 1;
767 Next := StrScan(Strt, Delim);
768 end;
769 if Next = nil then Next := StrEnd(Strt);
770 if i < PieceNum
771 then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece
772 else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next);
773end;
774
775procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
776 FromString: string);
777var
778 i: integer;
779
780begin
781 for i := low(Pieces) to high(Pieces) do
782 SetPiece(x, Delim, Pieces[i], Piece(FromString, Delim, Pieces[i]));
783end;
784
785procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
786var
787 i: integer;
788begin
789 for i := 0 to AList.Count - 1 do
790 AList[i] := Piece(AList[i], ADelim, PieceNum) + ADelim + AList[i];
791 AList.Sort;
792 for i := 0 to AList.Count - 1 do
793 AList[i] := Copy(AList[i], Pos(ADelim, AList[i]) + 1, MaxInt);
794end;
795
796function DelimCount(const Str, Delim: string): integer;
797var
798 i, dlen, slen: integer;
799
800begin
801 Result := 0;
802 i := 1;
803 dlen := length(Delim);
804 slen := length(Str) - dlen + 1;
805 while(i <= slen) do
806 begin
807 if(copy(Str,i,dlen) = Delim) then
808 begin
809 inc(Result);
810 inc(i,dlen);
811 end
812 else
813 inc(i);
814 end;
815end;
816
817type
818 TREStrings = class(TStrings)
819 protected
820 FPlainText: Boolean;
821 public
822 property PlainText: Boolean read FPlainText write FPlainText;
823 end;
824
825type
826 QuickCopyError = class(Exception);
827
828procedure QuickCopy(AFrom, ATo: TObject);
829var
830 ms: TMemoryStream;
831 idx: integer;
832 str: array[0..1] of TStrings;
833 fix: array[0..1] of boolean;
834
835 procedure GetStrings(obj: TObject);
836 begin
837 if (CompareText(obj.ClassName, 'TRichEditStrings') = 0) then
838 raise QuickCopyError.Create('You must pass the TRichEdit object into QuickCopy, NOT it''s Lines property.');
839 if obj is TStrings then
840 str[idx] := TStrings(obj)
841 else
842 if obj is TMemo then
843 str[idx] := TMemo(obj).Lines
844 else
845 if obj is TORListBox then
846 str[idx] := TORListBox(obj).Items
847 else
848 if obj is TListBox then
849 str[idx] := TListBox(obj).Items
850 else
851 if obj is TRichEdit then
852 begin
853 with TRichEdit(obj) do
854 begin
855 str[idx] := Lines;
856 if not PlainText then
857 begin
858 fix[idx] := TRUE;
859 PlainText := TRUE;
860 end;
861 end;
862 end
863 else
864 raise QuickCopyError.Create('Unsupported object type (' + obj.ClassName +
865 ') passed into QuickCopy.');
866 inc(idx);
867 end;
868
869
870begin
871 fix[0] := FALSE;
872 fix[1] := FALSE;
873 idx := 0;
874 GetStrings(AFrom);
875 GetStrings(ATo);
876 ms := TMemoryStream.Create;
877 try
878 str[0].SaveToStream(ms);
879 ms.Seek(0, soFromBeginning);
880 str[1].LoadFromStream(ms);
881 finally
882 ms.Free;
883 end;
884 if fix[0] then TRichEdit(AFrom).PlainText := FALSE;
885 if fix[1] then TRichEdit(ATo).PlainText := FALSE;
886end;
887
888function ValidFileName(const InitialFileName: string): string;
889var
890 i: integer;
891
892begin
893 Result := InitialFileName;
894 i := 1;
895 while i <= length(Result) do
896 begin
897 if Result[i] in ['a'..'z','A'..'Z','0'..'9',#32] then
898 inc(i)
899 else
900 delete(Result,i,1);
901 end;
902end;
903
904procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
905var
906 i, SpacePos: Integer;
907 x: string;
908 NewList: TStringList;
909begin
910 NewList := TStringList.Create;
911 try
912 for i := 0 to AList.Count - 1 do
913 begin
914 if Length(AList[i]) > MaxLength then
915 begin
916 x := AList[i];
917 while Length(x) > MaxLength do
918 begin
919 SpacePos := MaxLength;
920// while SpacePos > 0 do {**REV**} removed after v11b
921// if (x[SpacePos] <> ' ') then Dec(SpacePos); {**REV**} removed after v11b
922 while (x[SpacePos] <> ' ') and (SpacePos > 1) do Dec(SpacePos); {**REV**} {changed 0 to 1}
923 if SpacePos = 1 then SpacePos := MaxLength; {**REV**} {changed 0 to 1}
924 NewList.Add(Copy(x, 1, SpacePos )); // CQ PSI-05-040 change SpacePos-1 to SpacePos
925 Delete(x, 1, SpacePos);
926 end; {while Length(x)}
927 if Length(x) > 0 then NewList.Add(x);
928 end {then}
929 else NewList.Add(AList[i]);
930 end; {for i}
931 AList.Clear;
932 AList.Assign(NewList);
933 finally
934 NewList.Free;
935 end;
936end;
937
938{ Display functions }
939
940(*
941procedure ClearControl(AControl: TControl);
942{ clears a control, removes text and listbox items }
943begin
944 if AControl is TLabel then with TLabel(AControl) do Caption := ''
945 else if AControl is TButton then with TButton(AControl) do Caption := ''
946 else if AControl is TEdit then with TEdit(AControl) do Text := ''
947 else if AControl is TMemo then with TMemo(AControl) do Clear
948 else if AControl is TListBox then with TListBox(AControl) do Clear
949 else if AControl is TORComboBox then with TORComboBox(AControl) do
950 begin
951 MItems.Clear;
952 Text := '';
953 end
954 else if AControl is TComboBox then with TComboBox(AControl) do
955 begin
956 Clear;
957 Text := '';
958 end;
959end;
960
961procedure ResetControl(AControl: TControl);
962{ clears text, deselects items, does not remove listbox or combobox items }
963begin
964 if AControl is TLabel then with TLabel(AControl) do Caption := ''
965 else if AControl is TButton then with TButton(AControl) do Caption := ''
966 else if AControl is TEdit then with TEdit(AControl) do Text := ''
967 else if AControl is TMemo then with TMemo(AControl) do Clear
968 else if AControl is TListBox then with TListBox(AControl) do ItemIndex := -1
969 else if AControl is TORComboBox then with TORComboBox(AControl) do
970 begin
971 Text := '';
972 ItemIndex := -1;
973 end
974 else if AControl is TComboBox then with TComboBox(AControl) do
975 begin
976 Text := '';
977 ItemIndex := -1;
978 end;
979end;
980*)
981
982function InfoBox(const Text, Caption: string; Flags: Word): Integer;
983{ wrap the messagebox object in case we want to modify it later }
984begin
985 Result := Application.MessageBox(PChar(Text), PChar(Caption), Flags or MB_TOPMOST);
986end;
987
988procedure LimitEditWidth(AControl: TWinControl; NumChars: Integer);
989{ limits the editing area to be no more than N characters (also sets small left margin) }
990const
991 LEFT_MARGIN = 4;
992var
993 ARect: TRect;
994 AHandle: DWORD;
995 AWidth, i: Integer;
996 x: string;
997begin
998 Inc(NumChars);
999 SetString(x, nil, NumChars);
1000 for i := 1 to NumChars do x[i] := 'X';
1001 with AControl do
1002 begin
1003 AHandle := 0;
1004 if AControl is TEdit then AHandle := TEdit(AControl).Font.Handle;
1005 if AControl is TMemo then AHandle := TMemo(AControl).Font.Handle;
1006 if AControl is TRichEdit then AHandle := TRichEdit(AControl).Font.Handle;
1007 if AHandle = 0 then Exit;
1008 AWidth := TextWidthByFont(AHandle, x);
1009 ARect := Rect(LEFT_MARGIN, 0, AWidth + LEFT_MARGIN, ClientHeight);
1010 // set the editing rectangle to with with of NumChars
1011 SendMessage(Handle, EM_SETRECT, 0, Longint(@ARect));
1012 // turn on auto-scrolling for a rich edit
1013 if AControl is TRichEdit
1014 then SendMessage(Handle, EM_SETOPTIONS, ECOOP_OR, ECO_AUTOHSCROLL + ECO_AUTOVSCROLL);
1015 end;
1016end;
1017
1018function BaseFont: TFont;
1019begin
1020 result := FBaseFont;
1021end;
1022
1023function MainFont: TFont;
1024begin
1025 if Application.MainForm <> nil
1026 then Result := Application.MainForm.Font
1027 else Result := BaseFont;
1028end;
1029
1030function MainFontSize: Integer;
1031{ return font size of the Main Form in the application }
1032begin
1033 Result := MainFont.Size;
1034end;
1035
1036function FontWidthSubPixel( Font: TFont): real;
1037{ return in pixels the average character width of the font passed in FontHandle }
1038var
1039 TotalWidth: integer;
1040begin
1041 TotalWidth := TextWidthByFont( Font.Handle,
1042 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz');
1043 result := TotalWidth / 52;
1044end;
1045
1046function FontWidthPixel( Font: TFont): integer;
1047begin
1048 //Round() is too fancy to be correct here
1049 result := Trunc(FontWidthSubPixel(Font) + 0.5);
1050end;
1051
1052function MainFontWidth: Integer;
1053begin
1054 Result := FontWidthPixel(MainFont);
1055end;
1056
1057function MainFontHeight: Integer;
1058{ return font size of the Main Form in the application.
1059Note that TFont.Height is negative of what we want (see Delphi documentation)}
1060begin
1061 Result := Abs(MainFont.Height);
1062end;
1063
1064procedure RedrawSuspend(AHandle: HWnd);
1065begin
1066 SendMessage(AHandle, WM_SETREDRAW, 0, 0);
1067end;
1068
1069procedure RedrawActivate(AHandle: HWnd);
1070begin
1071 SendMessage(AHandle, WM_SETREDRAW, 1, 0);
1072 InvalidateRect(AHandle, nil, True);
1073end;
1074
1075procedure ResetSelectedForList(AListBox: TListBox);
1076var
1077 i: Integer;
1078begin
1079 with AListBox do for i := 0 to Items.Count - 1 do Selected[i] := False;
1080end;
1081
1082function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
1083begin
1084 result := Trunc( OldWidth *FontWidthSubPixel(NewFont) / FontWidthSubPixel(OldFont)
1085 +0.5);
1086end;
1087
1088function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
1089begin
1090 result := Trunc( OldHeight *Abs(NewFont.Height) / Abs(OldFont.Height)
1091 +0.5);
1092end;
1093
1094procedure ResizeToFont(FontSize: Integer; var W, H: Integer);
1095{ resizes form relative to the font size, assumes form designed with
1096DefaultFont (>MS Sans Serif 8pt<) }
1097var
1098 Font: TFont;
1099begin
1100 Font := TFont.Create;
1101 Font.Name := BaseFontName;
1102 Font.Size := FontSize;
1103 W := ResizeWidth( BaseFont, Font, W);
1104 H := ResizeHeight( BaseFont, Font, H);
1105end;
1106
1107procedure ResizeHeaderControl( OldFont: TFont; NewFont: TFont; Control: THeaderControl);
1108{Tested against fOrders page.}
1109var
1110 i: integer;
1111begin
1112 for i := 0 to Control.Sections.Count-1 do
1113 Control.Sections[i].Width := ResizeWidth( OldFont, NewFont, Control.Sections[i].Width);
1114end;
1115
1116procedure ResizeListView( OldFont: TFont; NewFont: TFont; Control: TListView);
1117var
1118 i: integer;
1119begin
1120 if not Assigned(Control.OnResize) then
1121 for i := 0 to Control.Columns.Count-1 do
1122 Control.Columns[i].Width := ResizeWidth( OldFont, NewFont, Control.Columns[i].Width);
1123end;
1124
1125procedure ResizeComboBox( OldFont: TFont; NewFont: TFont; Control: TComboBox);
1126begin
1127 Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
1128end;
1129
1130procedure ResizeListBox( OldFont: TFont; NewFont: TFont; Control: TListBox);
1131begin
1132 Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
1133end;
1134
1135procedure ResizeCheckListBox( OldFont: TFont; NewFont: TFont; Control: TCheckListBox);
1136begin
1137 Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
1138end;
1139
1140procedure ResizeDescendants( OldFont: TFont; NewFont: TFont; AControl: TWinControl);
1141var
1142 i: integer;
1143 Child: TControl;
1144 VisibleWidth, TotalWidth: integer;
1145 VisibleHeight, TotalHeight: integer;
1146begin
1147 if AControl.Align <> alNone then
1148 Application.ProcessMessages;
1149 AControl.DisableAlign;
1150 try
1151 //I think I finally got this next part right, so I will try to explain what
1152 //it is doing.
1153 //At this stage, the control is resized, but all of the childern are in
1154 //original size.
1155 //These children are corretly aligned to the visible part of the control,
1156 //but may not be correctly aligned in the underlying canvas if there are
1157 //scroll bars.
1158 //We wish to transform the children to have the correct new size and be
1159 //aligned to the new underlying canvas size.
1160
1161 //For the widths, I have kept track of what parts of the screen we are
1162 //resizing. The height will work the same way.
1163 //The notation is A[B]C, where A is the space to the left of the child
1164 //control, B is the space containing the child control, and C is the space
1165 //to the right.
1166 VisibleWidth := AControl.Width;
1167 VisibleHeight := AControl.Height;
1168 TotalWidth := VisibleWidth;
1169 TotalHeight := VisibleHeight;
1170 if AControl is TScrollingWinControl then
1171 begin
1172 TotalWidth := HigherOf(TotalWidth, TScrollingWinControl(AControl).HorzScrollBar.Range);
1173 TotalHeight := HigherOf(TotalHeight, TScrollingWinControl(AControl).VertScrollBar.Range);
1174 end;
1175 for i := 0 to AControl.ControlCount -1 do begin
1176 Child := AControl.Controls[i];
1177 //Tab sheets auto-size with their parents
1178 if not (Child is TTabSheet) then
1179 with Child do begin
1180 if [akLeft,akRight] <= Anchors then //X[.]X
1181 Width := TotalWidth - ResizeWidth( OldFont, NewFont, VisibleWidth - Width)
1182 else //.[X].
1183 Width := ResizeWidth( OldFont, NewFont, Width);
1184 if not(akLeft in Anchors) then //.[X]X
1185 Left := TotalWidth - ResizeWidth( OldFont, NewFont, VisibleWidth - Left)
1186 else
1187 Left := ResizeWidth( OldFont, NewFont, Left); //X[.].
1188 if [akTop,akBottom] <= Anchors then
1189 Height := TotalHeight - ResizeHeight( OldFont, NewFont, VisibleHeight - Height)
1190 else
1191 Height := ResizeHeight( OldFont, NewFont, Height);
1192 if not(akTop in Anchors) then
1193 Top := TotalHeight - ResizeHeight( OldFont, NewFont, VisibleHeight - Top)
1194 else
1195 Top := ResizeHeight( OldFont, NewFont, Top);
1196 end;
1197 //Recurse. Let Auto-Size panels take care of themselves
1198 if (Child is TWinControl) and not (Child is TORAutoPanel) then
1199 ResizeDescendants( OldFont, NewFont, TWinControl(Child));
1200 if Child is TComboBox then
1201 ResizeComboBox( OldFont, NewFont, TComboBox(Child));
1202 if Child is TCheckListBox then
1203 ResizeCheckListBox( OldFont, NewFont, TCheckListBox(Child));
1204 if Child is THeaderControl then
1205 ResizeHeaderControl( OldFont, NewFont, THeaderControl(Child));
1206 if Child is TListBox then
1207 ResizeListBox( OldFont, NewFont, TListBox(Child));
1208 if Child is TListView then
1209 ResizeListView( OldFont, NewFont, TListView(Child));
1210 if Child is TDrawGrid then with TDrawGrid(Child) do
1211 //from Win32 "How to Calculate the Height of Edit Control..."
1212 DefaultRowHeight := Abs(NewFont.Height) * 3 div 2;
1213 if Child is TTabControl then with TTabControl(Child) do begin
1214 if Tabs.Count > 0 then
1215 TabWidth := ResizeWidth( OldFont, NewFont, TabWidth);
1216 Width := TabWidth * Tabs.Count +3;
1217 end;
1218 end;
1219 finally
1220 AControl.EnableAlign;
1221 end;
1222end;
1223
1224procedure ResizeChartFonts( OldFont: TFont; NewFont: TFont; Control: TChart);
1225var
1226 i: integer;
1227begin
1228 with Control do begin
1229 if LeftAxis.Title.Font.Size = OldFont.Size then
1230 LeftAxis.Title.Font.Size := NewFont.Size;
1231 if LeftAxis.LabelsFont.Size = OldFont.Size then
1232 LeftAxis.LabelsFont.Size := NewFont.Size;
1233 if BottomAxis.Title.Font.Size = OldFont.Size then
1234 BottomAxis.Title.Font.Size := NewFont.Size;
1235 if BottomAxis.LabelsFont.Size = OldFont.Size then
1236 BottomAxis.LabelsFont.Size := NewFont.Size;
1237 if Legend.Font.Size = OldFont.Size then
1238 Legend.Font.Size := NewFont.Size;
1239 if Title.Font.Size = OldFont.Size then
1240 Title.Font.Size := NewFont.Size;
1241 for i := 0 to SeriesCount - 1 do
1242 if Series[i].Marks.Font.Size = OldFont.Size then
1243 Series[i].Marks.Font.Size := NewFont.Size;
1244 end;
1245end;
1246
1247procedure ResizeFontsInDescendants( OldFont: TFont; NewFont: TFont; AControl: TWinControl);
1248var
1249 i: integer;
1250 Child: TControl;
1251 RESelectionStart: integer;
1252 RESelectionLength: integer;
1253begin
1254 for i := 0 to AControl.ControlCount -1 do begin
1255 Child := AControl.Controls[i];
1256 if Child is TRichEdit then begin
1257 with TRichEdit(Child) do
1258 if Font.Size = OldFont.Size then begin
1259 if not ParentFont then
1260 Font.Size := NewFont.Size;
1261 RESelectionStart := SelStart;
1262 RESelectionLength := SelLength;
1263 SelectAll;
1264 SelAttributes.Size := NewFont.Size;
1265 DefAttributes.Size := NewFont.Size;
1266 SelStart := RESelectionStart;
1267 SelLength := RESelectionLength;
1268 end
1269 end
1270 else
1271 if Child is TChart then
1272 ResizeChartFonts( OldFont, NewFont, TChart(Child))
1273 else
1274 with TFontControl(Child) do
1275 if (Font.Size = OldFont.Size) and not ParentFont then
1276 Font.Size := NewFont.Size;
1277
1278 if Child is TWinControl then
1279 ResizeFontsInDescendants( OldFont, NewFont, TWinControl(Child));
1280 end;
1281end;
1282
1283procedure ForceInsideWorkArea( var Rect: TRect);
1284var
1285 Frame: TRect;
1286begin
1287 Frame := Screen.WorkAreaRect;
1288 {Veritcal version:}
1289 {Align bottom (preserving height) if needed}
1290 if Rect.Bottom > Frame.Bottom then
1291 begin
1292 Rect.Top := Rect.Top + Frame.Bottom - Rect.Bottom;
1293 Rect.Bottom := Frame.Bottom;
1294 end;
1295 {Then align top (preserving height) if needed}
1296 if Rect.Top < Frame.Top then
1297 begin
1298 Rect.Bottom := Rect.Bottom + Frame.Top - Rect.Top;
1299 Rect.Top := Frame.Top;
1300 end;
1301 {Now shrink (preserving top) if needed}
1302 if Rect.Bottom > Frame.Bottom then
1303 Rect.Bottom := Frame.Bottom;
1304 {Horizontal version:}
1305 if Rect.Right > Frame.Right then
1306 begin
1307 Rect.Left := Rect.Left + Frame.Right - Rect.Right;
1308 Rect.Right := Frame.Right;
1309 end;
1310 if Rect.Left < Frame.Left then
1311 begin
1312 Rect.Right := Rect.Right + Frame.Left - Rect.Left;
1313 Rect.Left := Frame.Left;
1314 end;
1315 if Rect.Right > Frame.Right then
1316 Rect.Right := Frame.Right;
1317end;
1318
1319procedure ResizeFormToFont(AForm: TForm);
1320var
1321 Rect: TRect;
1322begin
1323 with AForm do begin
1324 ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
1325 ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
1326 HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
1327 VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
1328 Rect := BoundsRect;
1329 ForceInsideWorkArea(Rect);
1330 BoundsRect := Rect;
1331 ResizeFontsInDescendants( Font, MainFont, AForm);
1332 //Important: We are using the font to calculate everything, so don't
1333 //change font until now.
1334 Font.Size := MainFont.Size;
1335 end;
1336end;
1337
1338procedure ResizeAnchoredFormToFont( AForm: TForm);
1339var
1340 Rect: TRect;
1341begin
1342 with AForm do begin
1343 ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
1344 ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
1345 HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
1346 VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
1347 Rect := BoundsRect;
1348 ForceInsideWorkArea(Rect);
1349 BoundsRect := Rect;
1350 ResizeDescendants( Font, MainFont, AForm);
1351 ResizeFontsInDescendants( Font, MainFont, AForm);
1352 //Important: We are using the font to calculate everything, so don't
1353 //change font until now.
1354 Font.Size := MainFont.Size;
1355 end;
1356end;
1357
1358procedure SetEqualTabStops(AControl: TControl; TabWidth: Integer = 8);
1359{ sets tab stops to match the width when the tab is replaced with TabWidth spaces }
1360const
1361 MAX_TABS = 10;
1362 POINTS_PER_INCH = 72;
1363var
1364 DC: HDC;
1365 i, HorzPixelsPerInch, PixelsPerTabWidth, PointsPerTabWidth: Integer;
1366begin
1367 if AControl is TRichEdit then with TRichEdit(AControl) do
1368 begin
1369 DC := GetDC(0);
1370 HorzPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSX);
1371 ReleaseDC(0, DC);
1372 PixelsPerTabWidth := TextWidthByFont(Font.Handle, StringOfChar(' ', TabWidth));
1373 PointsPerTabWidth := Round((PixelsPerTabWidth / HorzPixelsPerInch) * POINTS_PER_INCH);
1374 for i := 0 to MAX_TABS do Paragraph.Tab[i] := PointsPerTabWidth * Succ(i);
1375 end;
1376end;
1377
1378procedure StatusText(const S: string);
1379{ sends a user defined message to the main window of an application to display the text
1380 found in lParam. Only useful if the main window has message event for this message }
1381begin
1382 if (Application.MainForm <> nil) and (Application.MainForm.HandleAllocated)
1383 then SendMessage(Application.MainForm.Handle, UM_STATUSTEXT, 0, Integer(PChar(S)));
1384end;
1385
1386function ShowMsgOn(AnExpression: Boolean; const AMsg, ACaption: string): Boolean;
1387begin
1388 Result := AnExpression;
1389 if Result then InfoBox(AMsg, ACaption, MB_OK);
1390end;
1391
1392function TextWidthByFont(AFontHandle: THandle; const x: string): Integer;
1393{ returns the width of a string in pixels, given a FONT handle and string }
1394var
1395 DC: HDC;
1396 SaveFont: HFont;
1397 TextSize: TSize;
1398begin
1399 DC := GetDC(0);
1400 SaveFont := SelectObject(DC, AFontHandle);
1401 GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
1402 Result := TextSize.cx;
1403 SelectObject(DC, SaveFont);
1404 ReleaseDC(0, DC);
1405end;
1406
1407function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
1408var
1409 DC: HDC;
1410 SaveFont: HFont;
1411 TextSize: TSize;
1412
1413begin
1414 DC := GetDC(0);
1415 SaveFont := SelectObject(DC, AFontHandle);
1416 GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
1417 Result := TextSize.cy;
1418 SelectObject(DC, SaveFont);
1419 ReleaseDC(0, DC);
1420end;
1421
1422function WrappedTextHeightByFont(Canvas: TCanvas; NewFont: TFont; ItemText: string; var ARect: TRect): integer;
1423var
1424 MyTextMetric: TTextMetric;
1425 MyFontName: Array [0..31] of char;
1426 MyFontHandle, RealFontHandle: HFONT;
1427begin
1428 { The next bit is a bunch of Windows code to accomodate the DrawText calls
1429 inside the try..finally block. The issue here comes when resizing the font.
1430 The Delphi font property is already set, but the DrawText call uses a
1431 Windows handle and the handle's font hasn't been set to the new value.}
1432 {This still has a vertical sizing bug when there is text that doesn't wrap but is too
1433 wide to display in the window (think long medicine names and 24 pt font on a
1434 640*480 screen)}
1435 MyFontHandle := 0;
1436 RealFontHandle := 0;
1437 if GetTextMetrics(Canvas.Handle, MyTextMetric) then
1438 if GetTextFace( Canvas.Handle, 32, @MyFontName) <> 0 then with MyTextMetric do
1439 MyFontHandle := CreateFont( NewFont.Height,
1440 tmAveCharWidth * Abs(NewFont.Height) div tmHeight,
1441 0,
1442 0,
1443 tmWeight,
1444 tmItalic,
1445 tmUnderlined,
1446 tmStruckOut,
1447 tmCharSet,
1448 OUT_DEFAULT_PRECIS,
1449 CLIP_DEFAULT_PRECIS,
1450 DEFAULT_QUALITY,
1451 FF_DONTCARE or DEFAULT_PITCH,
1452 @MyFontName);
1453 if MyFontHandle <> 0 then
1454 RealFontHandle := SelectObject( Canvas.Handle, MyFontHandle);
1455 try
1456 result := DrawText(Canvas.Handle, PChar(ItemText), Length(ItemText), ARect,
1457 DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK) + 2;
1458 finally
1459 if MyFontHandle <> 0 then begin
1460 SelectObject( Canvas.Handle, RealFontHandle);
1461 DeleteObject( MyFontHandle );
1462 end;
1463 end;
1464end;
1465
1466function NumCharsFitInWidth(AFontHandle: THandle; const x: string; const MaxLen: integer): Integer;
1467var
1468 DC: HDC;
1469 SaveFont: HFont;
1470 TextSize: TSize;
1471 TmpX: string;
1472 done: boolean;
1473 l,h: integer;
1474
1475begin
1476 DC := GetDC(0);
1477 SaveFont := SelectObject(DC, AFontHandle);
1478 try
1479 h := length(x);
1480 l := 0;
1481 Result := h;
1482 repeat
1483 TmpX := copy(x, 1, Result);
1484 GetTextExtentPoint32(DC, PChar(TmpX), Length(TmpX), TextSize);
1485 if(TextSize.cx > MaxLen) then
1486 begin
1487 h := Result;
1488 Result := (l+h) div 2;
1489 done := (Result <= l);
1490 end
1491 else
1492 begin
1493 l := Result;
1494 Result := (l+h+1) div 2;
1495 done := (Result >= h);
1496 end;
1497 until(done);
1498 finally
1499 SelectObject(DC, SaveFont);
1500 ReleaseDC(0, DC);
1501 end;
1502end;
1503
1504function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
1505begin
1506 if(assigned(PopupMenu) and assigned(Sender) and (Sender is TPopupMenu) and
1507 assigned(PopupMenu.PopupComponent)) then
1508 Result := PopupMenu.PopupComponent
1509 else
1510 Result := Screen.ActiveControl;
1511end;
1512
1513procedure ReformatMemoParagraph(AMemo: TCustomMemo);
1514{ rewrap lines starting with current line until there is a line that starts with whitespace }
1515var
1516 ALine: Integer;
1517 x, OldText, NewText: string;
1518begin
1519 with AMemo do
1520 begin
1521 ALine := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
1522 repeat
1523 Inc(ALine);
1524 until (ALine >= Lines.Count) or (Lines[ALine] = '') or (Ord(Lines[ALine][1]) <= 32);
1525 SelLength := SendMessage(Handle, EM_LINEINDEX, ALine, 0) - SelStart - 1;
1526 if SelLength < 1 then Exit;
1527 OldText := SelText;
1528 NewText := '';
1529 repeat
1530 x := Copy(OldText, 1, Pos(CRLF, OldText) - 1);
1531 if Length(x) = 0 then x := OldText;
1532 Delete(OldText, 1, Length(x) + 2); {delete text + CRLF}
1533 if (NewText <> '') and (Copy(NewText, Length(NewText), 1) <> ' ') and
1534 (Copy(x, 1, 1) <> ' ') then NewText := NewText + ' ';
1535 NewText := NewText + x;
1536 until OldText = '';
1537 SelText := NewText;
1538 end;
1539end;
1540
1541var
1542 uReadOnlyColor: TColor;
1543 uHaveReadOnlyColor: boolean = FALSE;
1544
1545function ReadOnlyColor: TColor;
1546begin
1547 if not uHaveReadOnlyColor then
1548 begin
1549 uHaveReadOnlyColor := TRUE;
1550 if ColorToRGB(clWindow) = ColorToRGB(clWhite) then
1551 uReadOnlyColor := $00F0FBFF
1552 else
1553 uReadOnlyColor := clWindow;
1554 end;
1555 Result := uReadOnlyColor;
1556end;
1557
1558{ ListBox Grid functions }
1559
1560procedure ListGridDrawCell(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
1561 const x: string; WordWrap: Boolean);
1562var
1563 i, Format: Integer;
1564 ARect: TRect;
1565begin
1566 ARect := AListBox.ItemRect(ARow);
1567 ARect.Left := 0;
1568 for i := 0 to AColumn - 1 do ARect.Left := ARect.Left + AHeader.Sections[i].Width;
1569 Inc(ARect.Left, 2);
1570 ARect.Right := ARect.Left + AHeader.Sections[AColumn].Width - 6;
1571 if WordWrap
1572 then Format := (DT_LEFT or DT_NOPREFIX or DT_WORDBREAK)
1573 else Format := (DT_LEFT or DT_NOPREFIX);
1574 DrawText(AListBox.Canvas.Handle, PChar(x), Length(x), ARect, Format);
1575end;
1576
1577procedure ListGridDrawLines(AListBox: TListBox; AHeader: THeaderControl; Index: Integer;
1578 State: TOwnerDrawState);
1579var
1580 i, RightSide: Integer;
1581 ARect: TRect;
1582begin
1583 with AListBox do
1584 begin
1585 ARect := ItemRect(Index);
1586 if odSelected in State then
1587 begin
1588 Canvas.Brush.Color := clHighlight;
1589 Canvas.Font.Color := clHighlightText
1590 end;
1591 Canvas.FillRect(ARect);
1592 Canvas.Pen.Color := clSilver;
1593 Canvas.MoveTo(ARect.Left, ARect.Bottom - 1);
1594 Canvas.LineTo(ARect.Right, ARect.Bottom - 1);
1595 RightSide := -2;
1596 for i := 0 to AHeader.Sections.Count - 1 do
1597 begin
1598 RightSide := RightSide + AHeader.Sections[i].Width;
1599 Canvas.MoveTo(RightSide, ARect.Bottom - 1);
1600 Canvas.LineTo(RightSide, ARect.Top);
1601 end;
1602 end;
1603end;
1604
1605function ListGridRowHeight(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
1606 const x: string): Integer;
1607var
1608 ARect: TRect;
1609begin
1610 ARect := AListBox.ItemRect(ARow);
1611 ARect.Right := AHeader.Sections[AColumn].Width - 6;
1612 Result := DrawText(AListBox.Canvas.Handle, PChar(x), Length(x), ARect,
1613 DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK) + 2;
1614end;
1615
1616(*
1617procedure SetEditWidth(AMemo: TMemo; AWidth: Integer);
1618begin
1619 //SetString(x, nil, AWidth);
1620 //for i := 1 to AWidth do x[i] := 'X';
1621end;
1622*)
1623
1624{ You MUST pass an address to an object variable to get KillObj to work }
1625procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
1626var
1627 Obj: TObject;
1628 Lst: TList;
1629 SLst: TStringList;
1630 i: integer;
1631
1632begin
1633 Obj := TObject(ptr^);
1634 if(assigned(Obj)) then
1635 begin
1636 if(KillObjects) then
1637 begin
1638 if(Obj is TList) then
1639 begin
1640 Lst := TList(Obj);
1641 for i := Lst.count-1 downto 0 do
1642 if assigned(Lst[i]) then
1643 TObject(Lst[i]).Free;
1644 end
1645 else
1646 if(Obj is TStringList) then
1647 begin
1648 SLst := TStringList(Obj);
1649 for i := SLst.count-1 downto 0 do
1650 if assigned(SLst.Objects[i]) then
1651 SLst.Objects[i].Free;
1652 end;
1653 end;
1654 Obj.Free;
1655 TObject(ptr^) := nil;
1656 end;
1657end;
1658
1659{ Idle Processing }
1660
1661type
1662 TIdleCaller = class(TObject)
1663 private
1664 FTimerActive: boolean;
1665 FCallList: TStringList;
1666 FDoneList: TStringList;
1667 FOldIdler: TIdleEvent;
1668 FTimer: TTimer;
1669 protected
1670 procedure AppIdle(Sender: TObject; var Done: Boolean);
1671 procedure TimerDone(Sender: TObject);
1672 public
1673 constructor Create;
1674 destructor Destroy; override;
1675 procedure Add(CallProc, DoneProc: TORIdleCallProc; Msg: string);
1676 end;
1677
1678var
1679 IdleCaller: TIdleCaller = nil;
1680
1681{ TIdleCaller }
1682
1683constructor TIdleCaller.Create;
1684begin
1685 inherited;
1686 FCallList := TStringList.Create;
1687 FDoneList := TStringList.Create;
1688 FTimer := TTimer.Create(nil);
1689 FTimer.Enabled := FALSE;
1690 FTimer.Interval := 2000; // 2 seconds
1691 FTimer.OnTimer := TimerDone;
1692 FTimerActive := FALSE;
1693 FOldIdler := Application.OnIdle;
1694 Application.OnIdle := AppIdle;
1695end;
1696
1697destructor TIdleCaller.Destroy;
1698begin
1699 Application.OnIdle := FOldIdler;
1700 FTimer.Enabled := FALSE;
1701 KillObj(@FTimer);
1702 KillObj(@FDoneList);
1703 KillObj(@FCallList);
1704 inherited;
1705end;
1706
1707procedure TIdleCaller.AppIdle(Sender: TObject; var Done: Boolean);
1708begin
1709 if(not FTimerActive) and (FCallList.Count > 0) then
1710 begin
1711 FTimer.Enabled := TRUE;
1712 FTimerActive := TRUE;
1713 end;
1714 if assigned(FOldIdler) then
1715 FOldIdler(Sender, Done);
1716end;
1717
1718procedure TIdleCaller.Add(CallProc, DoneProc: TORIdleCallProc; Msg: string);
1719begin
1720 FCallList.AddObject(Msg, TObject(@CallProc));
1721 FDoneList.AddObject(Msg, TObject(@DoneProc));
1722end;
1723
1724procedure TIdleCaller.TimerDone(Sender: TObject);
1725var
1726 CallProc, DoneProc: TORIdleCallProc;
1727 CallMsg, DoneMsg: string;
1728
1729begin
1730 FTimer.Enabled := FALSE;
1731 CallProc := TORIdleCallProc(FCallList.Objects[0]);
1732 CallMsg := FCallList[0];
1733 DoneProc := TORIdleCallProc(FDoneList.Objects[0]);
1734 DoneMsg := FDoneList[0];
1735 FCallList.Delete(0);
1736 FDoneList.Delete(0);
1737
1738 if(assigned(CallProc)) then
1739 CallProc(CallMsg);
1740 if(assigned(DoneProc)) then
1741 DoneProc(DoneMsg);
1742
1743 FTimerActive := FALSE;
1744end;
1745
1746{ do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet. }
1747procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
1748begin
1749 if(not assigned(IdleCaller)) then
1750 IdleCaller := TIdleCaller.Create;
1751 IdleCaller.Add(CallProc, nil, Msg);
1752end;
1753
1754procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
1755begin
1756 if(not assigned(IdleCaller)) then
1757 IdleCaller := TIdleCaller.Create;
1758 IdleCaller.Add(CallProc, DoneProc, Msg);
1759end;
1760
1761procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
1762var
1763 aCount, bCount: integer;
1764 butFound: boolean;
1765begin
1766for aCount := 0 to (aMenuItem.count - 1) do // Iterate through menu items.
1767 begin
1768 butFound := false;
1769 for bCount := 0 to (length(butItems) - 1) do // Check for match in exceptions array.
1770 begin
1771 if (aMenuItem.items[aCount] = butItems[bCount]) then
1772 begin
1773 butFound := true;
1774 break;
1775 end;
1776 end;
1777 if (not butFound) then
1778 aMenuItem.items[aCount].visible := false; // Hide menu item if not an exception.
1779 end;
1780end;
1781
1782function TabIsPressed : Boolean;
1783begin
1784 Result := Boolean(Hi(GetKeyState(VK_TAB))) and not Boolean(Hi(GetKeyState(VK_SHIFT)));
1785end;
1786
1787function ShiftTabIsPressed : Boolean;
1788begin
1789 Result := Boolean(Hi(GetKeyState(VK_TAB))) and Boolean(Hi(GetKeyState(VK_SHIFT)));
1790end;
1791
1792
1793initialization
1794 FBaseFont := TFont.Create;
1795 FBaseFont.Name := BaseFontName;
1796 FBaseFont.Size := BaseFontSize;
1797
1798finalization
1799 FBaseFont.Free;
1800 KillObj(@IdleCaller);
1801
1802end.
Note: See TracBrowser for help on using the repository browser.