Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

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

Last change on this file since 479 was 476, checked in by Kevin Toppenberg, 16 years ago
New WorldVistA Config Utility
File size: 55.9 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: