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

Last change on this file since 1245 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

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