source: cprs/branches/foia-cprs/CPRS-Lib/ORFn.pas@ 815

Last change on this file since 815 was 460, checked in by Kevin Toppenberg, 17 years ago

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