Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

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

Last change on this file since 599 was 456, checked in by Kevin Toppenberg, 16 years ago
Initial Upload of Official WV CPRS 1.0.26.76
File size: 56.3 KB

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

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

Download in other formats: