Context Navigation

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

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

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

Download in other formats: