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: 56.1 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);
111function HasKey(APerson: Int64; const AKey: string): Boolean;
112
113{ do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet }
114procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
115procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
116procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
117
118implementation // ---------------------------------------------------------------------------
119
120uses
121 ORCtrls, Grids, Chart, CheckLst;
122
123const
124 { names of months used by FormatFMDateTime }
125 MONTH_NAMES_SHORT: array[1..12] of string[3] =
126 ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
127 MONTH_NAMES_LONG: array[1..12] of string[9] =
128 ('January','February','March','April','May','June','July','August','September','October',
129 'November', 'December');
130
131 // ConvertSpecialStrings arrays
132 SearchChars: array[0..6] of String = (' Ii ',' Iii ',' Iv ',' Vi ',' Vii ',' Viii ',' Ix ');
133 ReplaceChars: array[0..6] of String = (' II ',' III ',' IV ',' VI ',' VII ',' VIII ',' IX ');
134
135 { table for calculating CRC values (DWORD is Integer in Delphi 3, Cardinal in Delphi 4}
136 CRC32_TABLE: array[0..255] of DWORD =
137 ($0, $77073096, $EE0E612C, $990951BA, $76DC419, $706AF48F, $E963A535, $9E6495A3,
138 $EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $9B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
139 $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
140 $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
141 $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
142 $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
143 $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
144 $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
145 $76DC4190, $1DB7106, $98D220BC, $EFD5102A, $71B18589, $6B6B51F, $9FBFE4A5, $E8B8D433,
146 $7807C9A2, $F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $86D3D2D, $91646C97, $E6635C01,
147 $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
148 $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
149 $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
150 $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
151 $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
152 $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
153 $EDB88320, $9ABFB3B6, $3B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $4DB2615, $73DC1683,
154 $E3630B12, $94643B84, $D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $A00AE27, $7D079EB1,
155 $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
156 $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
157 $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
158 $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
159 $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
160 $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
161 $9B64C2B0, $EC63F226, $756AA39C, $26D930A, $9C0906A9, $EB0E363F, $72076785, $5005713,
162 $95BF4A82, $E2B87A14, $7BB12BAE, $CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $BDBDF21,
163 $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
164 $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
165 $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
166 $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
167 $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
168 $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
169
170 {Properties assigned to BaseFont}
171 BaseFontSize = 8;
172 BaseFontName = 'MS Sans Serif';
173var
174 FBaseFont: TFont;
175type
176 EFMDateTimeError = class(Exception);
177
178 {TFontControl is an artifact used for font resizing. Do not add virtual
179 methods or class variables to it!}
180 TFontControl = class(TControl)
181 public
182 property Font;
183 property ParentFont;
184 end;
185
186{ Date/Time functions }
187
188function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
189{ converts a Delphi date/time type to a Fileman date/time (type double) }
190var
191 y, m, d, h, n, s, l: Word;
192 DatePart,TimePart: Integer;
193begin
194 DecodeDate(ADateTime, y, m, d);
195 DecodeTime(ADateTime, h, n, s, l);
196 DatePart := ((y-1700)*10000) + (m*100) + d;
197 TimePart := (h*10000) + (n*100) + s;
198 Result := DatePart + (TimePart / 1000000);
199end;
200
201function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
202{ converts a Fileman date/time (type double) to a Delphi date/time }
203var
204 ADate, ATime: TDateTime;
205 DatePart, TimePart: string;
206begin
207 DatePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 1);
208 TimePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 2) + '000000';
209 if Length(DatePart) <> 7 then raise EFMDateTimeError.Create('Invalid Fileman Date');
210 if Copy(TimePart, 1, 2) = '24' then TimePart := '23595959';
211 ADate := EncodeDate(StrToInt(Copy(DatePart, 1, 3)) + 1700,
212 StrToInt(Copy(DatePart, 4, 2)),
213 StrToInt(Copy(DatePart, 6, 2)));
214 ATime := EncodeTime(StrToInt(Copy(TimePart, 1, 2)),
215 StrToInt(Copy(TimePart, 3, 2)),
216 StrToInt(Copy(TimePart, 5, 2)), 0);
217 Result := ADate + ATime;
218end;
219
220function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
221{ adds / subtracts days from a Fileman date/time and returns the offset Fileman date/time }
222var
223 Julian: TDateTime;
224begin
225 Julian := FMDateTimeToDateTime(ADateTime);
226 Result := DateTimeToFMDateTime(Julian + DaysDiff);
227end;
228
229function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
230{ formats a Fileman Date/Time using (mostly) the same format string as Delphi FormatDateTime }
231var
232 x: string;
233 y, m, d, h, n, s: Integer;
234
235 function TrimFormatCount: Integer;
236 { delete repeating characters and count how many were deleted }
237 var
238 c: Char;
239 begin
240 Result := 0;
241 c := AFormat[1];
242 repeat
243 Delete(AFormat, 1, 1);
244 Inc(Result);
245 until CharAt(AFormat, 1) <> c;
246 end;
247
248begin {FormatFMDateTime}
249 Result := '';
250 if not (ADateTime > 0) then Exit;
251 x := FloatToStrF(ADateTime, ffFixed, 15, 6) + '0000000';
252 y := StrToIntDef(Copy(x, 1, 3), 0) + 1700;
253 m := StrToIntDef(Copy(x, 4, 2), 0);
254 d := StrToIntDef(Copy(x, 6, 2), 0);
255 h := StrToIntDef(Copy(x, 9, 2), 0);
256 n := StrToIntDef(Copy(x, 11, 2), 0);
257 s := StrToIntDef(Copy(x, 13, 2), 0);
258 while Length(AFormat) > 0 do
259 case UpCase(AFormat[1]) of
260 '"': begin // literal
261 Delete(AFormat, 1, 1);
262 while not (CharAt(AFormat, 1) in [#0, '"']) do
263 begin
264 Result := Result + AFormat[1];
265 Delete(AFormat, 1, 1);
266 end;
267 if CharAt(AFormat, 1) = '"' then Delete(AFormat, 1, 1);
268 end;
269 'D': case TrimFormatCount of // day/date
270 1: if d > 0 then Result := Result + IntToStr(d);
271 2: if d > 0 then Result := Result + FormatFloat('00', d);
272 end;
273 'H': case TrimFormatCount of // hour
274 1: Result := Result + IntToStr(h);
275 2: Result := Result + FormatFloat('00', h);
276 end;
277 'M': case TrimFormatCount of // month
278 1: if m > 0 then Result := Result + IntToStr(m);
279 2: if m > 0 then Result := Result + FormatFloat('00', m);
280 3: if m in [1..12] then Result := Result + MONTH_NAMES_SHORT[m];
281 4: if m in [1..12] then Result := Result + MONTH_NAMES_LONG[m];
282 end;
283 'N': case TrimFormatCount of // minute
284 1: Result := Result + IntToStr(n);
285 2: Result := Result + FormatFloat('00', n);
286 end;
287 'S': case TrimFormatCount of // second
288 1: Result := Result + IntToStr(s);
289 2: Result := Result + FormatFloat('00', s);
290 end;
291 'Y': case TrimFormatCount of // year
292 2: if y > 0 then Result := Result + Copy(IntToStr(y), 3, 2);
293 4: if y > 0 then Result := Result + IntToStr(y);
294 end;
295 else begin // other
296 Result := Result + AFormat[1];
297 Delete(AFormat, 1, 1);
298 end;
299 end; {case}
300end; {FormatFMDateTime}
301
302function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
303var
304 FMDateTime: TFMDateTime;
305begin
306 Result := ADateTime;
307 if IsFMDateTime(ADateTime) then
308 begin
309 FMDateTime := MakeFMDateTime(ADateTime);
310 Result := FormatFMDateTime(AFormat, FMDateTime);
311 end;
312end;
313
314function IsFMDateTime(x: string): Boolean;
315var
316 i: Integer;
317begin
318 Result := False;
319 if Length(x) < 7 then Exit;
320 for i := 1 to 7 do if not (x[i] in ['0'..'9']) then Exit;
321 if (Length(x) > 7) and (x[8] <> '.') then Exit;
322 if (Length(x) > 8) and not (x[9] in ['0'..'9']) then Exit;
323 Result := True;
324end;
325
326function MakeFMDateTime(const AString: string): TFMDateTime;
327begin
328 Result := -1;
329 if (Length(AString) > 0) and IsFMDateTime(AString) then Result := StrToFloat(AString);
330end;
331
332procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
333 PieceNum: Integer; KeepBad: boolean = FALSE);
334var
335 i: Integer;
336 s, x, x1: string;
337
338begin
339 for i := 0 to AList.Count - 1 do
340 begin
341 s := AList[i];
342 x := Piece(s, ADelim, PieceNum);
343 if Length(x) > 0 then
344 begin
345 x1 := FormatFMDateTime(AFormat, MakeFMDateTime(x));
346 if(x1 <> '') or (not KeepBad) then
347 x := x1;
348 end;
349 SetPiece(s, ADelim, PieceNum, x);
350 AList[i] := s;
351 end;
352end;
353
354{ Numeric functions }
355
356function HigherOf(i, j: Integer): Integer;
357{ returns the greater of two integers }
358begin
359 Result := i;
360 if j > i then Result := j;
361end;
362
363function LowerOf(i, j: Integer): Integer;
364{ returns the lesser of two integers }
365begin
366 Result := i;
367 if j < i then Result := j;
368end;
369
370function StrToFloatDef(const S: string; ADefault: Extended): Extended;
371begin
372 if not TextToFloat(PChar(S), Result, fvExtended) then
373 Result := ADefault;
374end;
375
376{ String functions }
377
378function CharAt(const x: string; APos: Integer): Char;
379{ returns a character at a given position in a string or the null character if past the end }
380begin
381 if Length(x) < APos then Result := #0 else Result := x[APos];
382end;
383
384function ContainsAlpha(const x: string): Boolean;
385{ returns true if the string contains any alpha characters }
386var
387 i: Integer;
388begin
389 Result := False;
390 for i := 1 to Length(x) do if x[i] in ['A'..'Z','a'..'z'] then
391 begin
392 Result := True;
393 break;
394 end;
395end;
396
397function ContainsVisibleChar(const x: string): Boolean;
398{ returns true if the string contains any printable characters }
399var
400 i: Integer;
401begin
402 Result := False;
403 for i := 1 to Length(x) do if x[i] in ['!'..'~'] then // ordinal values 33..126
404 begin
405 Result := True;
406 break;
407 end;
408end;
409
410function ConvertSpecialStrings(const x: string): string;
411var i : Integer;
412begin
413 for i := 0 to Length(SearchChars)-1 do
414 begin
415 Result := StringReplace(Result,SearchChars[i], ReplaceChars[i],[rfReplaceAll]);
416 end;
417end;
418
419function UpdateCrc32(Value: DWORD; var Buffer: array of Byte; Count: Integer): DWORD;
420var
421 i: integer;
422begin
423 Result:=Value;
424 for i := 0 to Pred(Count) do
425 Result := ((Result shr 8) and $00FFFFFF) xor
426 CRC32_TABLE[(Result xor Buffer[i]) and $000000FF];
427end;
428
429function CRCForFile(AFileName: string): DWORD;
430const
431 BUF_SIZE = 16383;
432type
433 TBuffer = array[0..BUF_SIZE] of Byte;
434var
435 Buffer: Pointer;
436 AHandle, BytesRead: Integer;
437begin
438 Result:=$FFFFFFFF;
439 GetMem(Buffer, BUF_SIZE);
440 AHandle := FileOpen(AFileName, fmShareDenyWrite);
441 repeat
442 BytesRead := FileRead(AHandle, Buffer^, BUF_SIZE);
443 Result := UpdateCrc32(Result, TBuffer(Buffer^), BytesRead);
444 until BytesRead <> BUF_SIZE;
445 FileClose(AHandle);
446 FreeMem(Buffer);
447 Result := not Result;
448end;
449
450function CRCForStrings(AStringList: TStrings): DWORD;
451{ returns a cyclic redundancy check for a list of strings }
452var
453 i, j: Integer;
454begin
455 Result:=$FFFFFFFF;
456 for i := 0 to AStringList.Count - 1 do
457 for j := 1 to Length(AStringList[i]) do
458 Result:=((Result shr 8) and $00FFFFFF) xor
459 CRC32_TABLE[(Result xor Ord(AStringList[i][j])) and $000000FF];
460end;
461
462function FilteredString(const x: string; ATabWidth: Integer = 8): string;
463var
464 i, j: Integer;
465begin
466 Result := '';
467 for i := 1 to Length(x) do
468 case x[i] of
469 #9: for j := 1 to (ATabWidth - (Length(Result) mod ATabWidth)) do
470 Result := Result + ' ';
471 #32..#127: Result := Result + x[i];
472 #128..#159: Result := Result + '?';
473 #10,#13,#160: Result := Result + ' ';
474 #161..#255: Result := Result + x[i];
475 end;
476 if Copy(Result, Length(Result), 1) = ' ' then Result := TrimRight(Result) + ' ';
477end;
478
479procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
480var
481 i, j, k: Integer;
482 x, y: string;
483begin
484 with AList do for i := 0 to Count - 1 do
485 begin
486 x := Strings[i];
487 y := '';
488 for j := 1 to Length(x) do
489 case x[j] of
490 #9: for k := 1 to (ATabWidth - (Length(y) mod ATabWidth)) do y := y + ' ';
491 #32..#127: y := y + x[j];
492 #128..#159: y := y + '?';
493 #160: y := y + ' ';
494 #161..#255: y := y + x[j];
495 end;
496 if Copy(y, Length(y), 1) = ' ' then y := TrimRight(y) + ' ';
497 Strings[i] := y;
498 //Strings[i] := TrimRight(y) + ' ';
499 end;
500end;
501
502function ExtractInteger(x: string): Integer;
503{ strips leading & trailing alphas to return an integer }
504var
505 i: Integer;
506begin
507 while (Length(x) > 0) and not (x[1] in ['0'..'9']) do Delete(x, 1, 1);
508 for i := 1 to Length(x) do if not (x[i] in ['0'..'9']) then break;
509 Result := StrToIntDef(Copy(x, 1, i - 1), 0);
510end;
511
512function ExtractFloat(x: string): Extended;
513{ strips leading & trailing alphas to return a float }
514var
515 i: Integer;
516begin
517 while (Length(x) > 0) and not (x[1] in ['0'..'9', '.']) do Delete(x, 1, 1);
518 for i := 1 to Length(x) do if not (x[i] in ['0'..'9','.']) then break;
519 Result := StrToFloatDef(Copy(x, 1, i - 1), 0);
520end;
521
522function ExtractDefault(Src: TStrings; const Section: string): string;
523var
524 i: Integer;
525begin
526 Result := '';
527 i := -1;
528 repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
529 Inc(i);
530 if (i < Src.Count) and (Src[i][1] <> '~') then repeat
531 if Src[i][1] = 'd' then Result := Copy(Src[i], 2, MaxInt);
532 Inc(i);
533 until (i = Src.Count) or (Src[i][1] = '~') or (Length(Result) > 0);
534end;
535
536procedure ExtractItems(Dest, Src: TStrings; const Section: string);
537var
538 i: Integer;
539begin
540 i := -1;
541 repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
542 Inc(i);
543 if (i < Src.Count) and (Src[i][1] <> '~') then repeat
544 if Src[i][1] = 'i' then Dest.Add(Copy(Src[i], 2, MaxInt));
545 Inc(i);
546 until (i = Src.Count) or (Src[i][1] = '~');
547end;
548
549procedure ExtractText(Dest, Src: TStrings; const Section: string);
550var
551 i: Integer;
552begin
553 i := -1;
554 repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
555 Inc(i);
556 if (i < Src.Count) and (Src[i][1] <> '~') then repeat
557 if Src[i][1] = 't' then Dest.Add(Copy(Src[i], 2, MaxInt));
558 Inc(i);
559 until (i = Src.Count) or (Src[i][1] = '~');
560end;
561
562procedure InvertStringList(AList: TStringList);
563var
564 i: Integer;
565begin
566 with AList do for i := 0 to ((Count div 2) - 1) do Exchange(i, Count - i - 1);
567end;
568
569function MixedCase(const x: string): string;
570var
571 i: integer;
572begin
573 Result := x;
574 for i := 2 to Length(x) do
575 if (not (x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
576 // save line if (not (x[i-1] in [' ','''',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
577 then Result[i] := Chr(Ord(x[i]) + 32)
578 else if ((x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['a'..'z'])
579 then Result[i] := Chr(Ord(x[i]) - 32);
580 //Call added to satisfy the need for special string handling(Roman Numerals II-XI) GRE-06/02
581 Result := ConvertSpecialStrings(x);
582end;
583
584procedure MixedCaseList(AList: TStrings);
585var
586 i: integer;
587begin
588 for i := 0 to (AList.Count - 1) do AList[i] := MixedCase(AList[i]);
589end;
590
591procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
592var
593 i: Integer;
594 x, p: string;
595begin
596 for i := 0 to (AList.Count - 1) do
597 begin
598 x := AList[i];
599 p := MixedCase(Piece(x, ADelim, PieceNum));
600 SetPiece(x, ADelim, PieceNum, p);
601 AList[i] := x;
602 end;
603end;
604
605function Piece(const S: string; Delim: char; PieceNum: Integer): string;
606{ returns the Nth piece (PieceNum) of a string delimited by Delim }
607var
608 i: Integer;
609 Strt, Next: PChar;
610begin
611 i := 1;
612 Strt := PChar(S);
613 Next := StrScan(Strt, Delim);
614 while (i < PieceNum) and (Next <> nil) do
615 begin
616 Inc(i);
617 Strt := Next + 1;
618 Next := StrScan(Strt, Delim);
619 end;
620 if Next = nil then Next := StrEnd(Strt);
621 if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
622end;
623
624function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
625{ returns several contiguous pieces }
626var
627 PieceNum: Integer;
628begin
629 Result := '';
630 for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
631 if Length(Result) > 0 then Delete(Result, Length(Result), 1);
632end;
633
634function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
635 char = '^'; CaseInsensitive: boolean = FALSE): integer;
636var
637 i: integer;
638
639begin
640 i := 0;
641 Result := 0;
642 while i <= high(Pieces) do
643 begin
644 if(CaseInsensitive) then
645 Result := CompareText(Piece(P1, Delim, Pieces[i]),
646 Piece(P2, Delim, Pieces[i]))
647 else
648 Result := CompareStr(Piece(P1, Delim, Pieces[i]),
649 Piece(P2, Delim, Pieces[i]));
650 if(Result = 0) then
651 inc(i)
652 else
653 break;
654 end;
655end;
656
657procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
658{ adds each piece to a TStrings list, the list is cleared first }
659var
660 APiece: string;
661begin
662 AList.Clear;
663 while Length(x) > 0 do
664 begin
665 APiece := Piece(x, ADelim, 1);
666 AList.Add(APiece);
667 Delete(x, 1, Length(APiece) + 1);
668 end;
669end;
670
671function ReverseStr(const x: string): string;
672var
673 i, j: Integer;
674begin
675 SetString(Result, PChar(x), Length(x));
676 i := 0;
677 for j := Length(x) downto 1 do
678 begin
679 Inc(i);
680 Result[i] := x[j];
681 end;
682end;
683
684procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
685{ sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
686var
687 i: Integer;
688 Strt, Next: PChar;
689begin
690 i := 1;
691 Strt := PChar(x);
692 Next := StrScan(Strt, Delim);
693 while (i < PieceNum) and (Next <> nil) do
694 begin
695 Inc(i);
696 Strt := Next + 1;
697 Next := StrScan(Strt, Delim);
698 end;
699 if Next = nil then Next := StrEnd(Strt);
700 if i < PieceNum
701 then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece
702 else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next);
703end;
704
705procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
706 FromString: string);
707var
708 i: integer;
709
710begin
711 for i := low(Pieces) to high(Pieces) do
712 SetPiece(x, Delim, Pieces[i], Piece(FromString, Delim, Pieces[i]));
713end;
714
715procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
716var
717 i: integer;
718begin
719 for i := 0 to AList.Count - 1 do
720 AList[i] := Piece(AList[i], ADelim, PieceNum) + ADelim + AList[i];
721 AList.Sort;
722 for i := 0 to AList.Count - 1 do
723 AList[i] := Copy(AList[i], Pos(ADelim, AList[i]) + 1, MaxInt);
724end;
725
726function DelimCount(const Str, Delim: string): integer;
727var
728 i, dlen, slen: integer;
729
730begin
731 Result := 0;
732 i := 1;
733 dlen := length(Delim);
734 slen := length(Str) - dlen + 1;
735 while(i <= slen) do
736 begin
737 if(copy(Str,i,dlen) = Delim) then
738 begin
739 inc(Result);
740 inc(i,dlen);
741 end
742 else
743 inc(i);
744 end;
745end;
746
747type
748 TREStrings = class(TStrings)
749 protected
750 FPlainText: Boolean;
751 public
752 property PlainText: Boolean read FPlainText write FPlainText;
753 end;
754
755type
756 QuickCopyError = class(Exception);
757
758procedure QuickCopy(AFrom, ATo: TObject);
759var
760 ms: TMemoryStream;
761 idx: integer;
762 str: array[0..1] of TStrings;
763 fix: array[0..1] of boolean;
764
765 procedure GetStrings(obj: TObject);
766 begin
767 if (CompareText(obj.ClassName, 'TRichEditStrings') = 0) then
768 raise QuickCopyError.Create('You must pass the TRichEdit object into QuickCopy, NOT it''s Lines property.');
769 if obj is TStrings then
770 str[idx] := TStrings(obj)
771 else
772 if obj is TMemo then
773 str[idx] := TMemo(obj).Lines
774 else
775 if obj is TORListBox then
776 str[idx] := TORListBox(obj).Items
777 else
778 if obj is TListBox then
779 str[idx] := TListBox(obj).Items
780 else
781 if obj is TRichEdit then
782 begin
783 with TRichEdit(obj) do
784 begin
785 str[idx] := Lines;
786 if not PlainText then
787 begin
788 fix[idx] := TRUE;
789 PlainText := TRUE;
790 end;
791 end;
792 end
793 else
794 raise QuickCopyError.Create('Unsupported object type (' + obj.ClassName +
795 ') passed into QuickCopy.');
796 inc(idx);
797 end;
798
799
800begin
801 fix[0] := FALSE;
802 fix[1] := FALSE;
803 idx := 0;
804 GetStrings(AFrom);
805 GetStrings(ATo);
806 ms := TMemoryStream.Create;
807 try
808 str[0].SaveToStream(ms);
809 ms.Seek(0, soFromBeginning);
810 str[1].LoadFromStream(ms);
811 finally
812 ms.Free;
813 end;
814 if fix[0] then TRichEdit(AFrom).PlainText := FALSE;
815 if fix[1] then TRichEdit(ATo).PlainText := FALSE;
816end;
817
818function ValidFileName(const InitialFileName: string): string;
819var
820 i: integer;
821
822begin
823 Result := InitialFileName;
824 i := 1;
825 while i <= length(Result) do
826 begin
827 if Result[i] in ['a'..'z','A'..'Z','0'..'9',#32] then
828 inc(i)
829 else
830 delete(Result,i,1);
831 end;
832end;
833
834procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
835{ change a TStringList so that all strings in the list are shorter than MaxLength }
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}
855 NewList.Add(Copy(x, 1, SpacePos - 1));
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
1713function HasKey(APerson: Int64; const AKey: string): Boolean;
1714begin
1715 Result := sCallV('ORWU NPHASKEY', [APerson, AKey]) = '1';
1716end;
1717
1718initialization
1719 FBaseFont := TFont.Create;
1720 FBaseFont.Name := BaseFontName;
1721 FBaseFont.Size := BaseFontSize;
1722
1723finalization
1724 FBaseFont.Free;
1725 KillObj(@IdleCaller);
1726
1727end.
Note: See TracBrowser for help on using the repository browser.