Context Navigation

ORFn.pas@ 732

Last change on this file since 732 was 541, checked in by Kevin Toppenberg, 15 years ago
TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 59.0 KB

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

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

Context Navigation

source: cprs/branches/tmg-cprs/CPRS-Lib/ORFn.pas@ 732

Download in other formats: