source: cprs/branches/GUI-config/CPRS-Lib/ORFn.pas@ 491

Last change on this file since 491 was 476, checked in by Kevin Toppenberg, 16 years ago

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