Context Navigation

ORFn.pas@ 1718

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

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

Context Navigation

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

Download in other formats: