source: cprs/trunk/CPRS-Lib/ORFn.pas@ 1710

Last change on this file since 1710 was 1679, checked in by healthsevak, 9 years ago

Updating the working copy to CPRS version 28

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