Context Navigation

source: trunk/Components/ControlsUtility.pas@ 457

Last change on this file since 457 was 457, checked in by ataylor, 2 years ago
Modify GetNiceDefaultFont to return the PM "Window Text" font setting, if available.
Property svn:eol-style set to `native`
File size: 24.5 KB

Line
1	unit ControlsUtility;
2
3	interface
4
5	uses
6	Classes, StdCtrls, SysUtils,
7	ACLUtility, StringUtilsUnit,
8	{$ifdef win32}
9	ExtCtrls, Forms, Controls, ComCtrls, Windows, Messages, Graphics;
10	{$else}
11	OS2Def, Forms;
12	{$endif}
13
14	const
15	{$ifdef win32}
16	Mnem = '&';
17	{$else}
18	Mnem = '~';
19	{$endif}
20
21	function GetComponentsVersion: string;
22
23	function InvertRGB( Arg: TColor ): TColor;
24
25	function GetScreenColorDepth: longint;
26	function GetVideoDriverName: string;
27
28	procedure SmartGetWindowPos( Form: TForm;
29	Var X, Y, W, H: longint;
30	Var Maximised: boolean );
31
32	procedure SmartSetWindowPos( Form: TForm;
33	X, Y, W, H: longint;
34	Maximised: boolean );
35
36	// Load/save form to inifile
37	Procedure SaveFormSizePosition( Form: TForm;
38	IniFile: TMyIniFile );
39	Procedure LoadFormSizePosition( Form: TForm;
40	IniFile: TMyIniFile );
41
42	{$ifdef os2}
43	// Utility access to the link (hand) cursor
44	Function GetLinkCursor: TCursor;
45
46	// set a wait cursor. If already set, increments a count
47	procedure SetWaitCursor;
48
49	// clear wait cursor. Only actually clears it if the count is now 0.
50	procedure ClearWaitCursor;
51
52	function GetNiceDefaultFont: TFont;
53	{$endif}
54
55	procedure StartTimer( Timer: TTimer );
56	procedure StopTimer( Timer: TTimer );
57
58	// Listbox utility functions
59	Function SelectedObject( ListBox: TListBox ): TObject;
60	Procedure SetSelectedByObject( ListBox: TListBox;
61	SelectObject: TObject );
62	Function SelectedItem( ListBox: TListBox ): string;
63	Procedure GetSelectedItems( ListBox: TListBox;
64	Dest: TStrings );
65
66	{$ifdef win32}
67	procedure SetFocusTo( Control: TWinControl );
68	{$else}
69	procedure SetFocusTo( Control: TControl );
70	{$endif}
71
72	{$ifdef win32}
73	Procedure AddBoldedLine( RichEdit: TRichEdit;
74	BoldPart: string;
75	NormalPart: string );
76
77	Procedure GetExpandedNodes( TreeView: TTreeView;
78	ExpandedNodeList: TStrings );
79
80	{$endif}
81
82	{$ifdef os2}
83	Procedure ScaleForm( Form: TForm;
84	OriginalFontWidth: longint;
85	OriginalFontHeight: longint );
86
87	// Validate all known SPCC components
88	// Checks that their memory storage is valid
89	// (refers to valid parts of the heap)
90	procedure ValidateSPCCObjects;
91
92	Procedure LogException( E: Exception;
93	const LogFileName: string;
94	const Title: string;
95	const AppVersion: string;
96	var F: TextFile );
97
98	// Find topmost form window of specified class name
99	Function FindTopFormWindow( const WindowClassName: string ): HWND;
100
101	{$endif}
102
103
104	implementation
105
106	{$ifdef os2}
107	uses
108	PMGpi, PMDev, PMShl, DOS, PMWin, BseDos,
109	TabCtrls,
110	MultiColumnListBox,
111	Graphics;
112
113	{$R ControlsUtility}
114
115	Var
116	TheLinkCursor: TCursor; // loaded on unit initialisation.
117	TheLinkPointer: TPointer; // loaded on unit initialisation.
118
119	function GetNiceDefaultFont: TFont;
120	var
121	OverrideAppFontName: string;
122	OverrideAppFontSize: string;
123	WindowTextFont: string;
124	DefaultFontFromIni: cstring;
125	DotPos: integer;
126	begin
127	// For Marco!
128	OverrideAppFontName := GetEnv( 'ACL_OVERRIDE_FONT_NAME' );
129	OverrideAppFontSize := GetEnv( 'ACL_OVERRIDE_FONT_SIZE' );
130
131	// Use PM "Window Text" font if defined
132	if OverrideAppFontName = '' then
133	begin
134	PrfQueryProfileString( HINI_USERPROFILE, // OS2 INI
135	'PM_SystemFonts', // app
136	'WindowText', // key
137	'', // default
138	DefaultFontFromIni,
139	sizeof( DefaultFontFromIni ));
140	if DefaultFontFromIni <> '' then
141	begin
142	WindowTextFont := DefaultFontFromIni;
143	DotPos := Pos('.', WindowTextFont );
144	if ( DotPos > 0 ) and ( DotPos < Length( WindowTextFont )) then
145	begin
146	OverrideAppFontSize := StrLeft( WindowTextFont, DotPos-1 );
147	OverrideAppFontName := StrSubstringFrom( WindowTextFont, DotPos+1 );
148	end;
149	end;
150	end;
151
152	try
153	if OverrideAppFontName <> '' then
154	begin
155	Result := Screen.GetFontFromPointSize( OverrideAppFontName,
156	StrToInt( OverrideAppFontSize ) );
157	if Result <> nil then
158	exit;
159	end;
160	except
161	end;
162
163	if Application.DBCSSystem then
164	begin
165	// try Warpsans Combined
166	Result := Screen.GetFontFromPointSize( 'WarpSans Combined', 9 );
167	if Result <> nil then
168	// ok use warpsans
169	exit;
170	end;
171	// try warpsans.9
172	Result := Screen.GetFontFromPointSize( 'WarpSans', 9 );
173	if Result <> nil then
174	// ok use warpsans
175	exit;
176
177	// try Helv.8
178	Result := Screen.GetFontFromPointSize( 'Helv', 8 );
179	if Result <> nil then
180	// ok use helv
181	exit;
182
183	// Ok, system default
184	Result := Screen.DefaultFont;
185	end;
186	{$endif}
187
188	var
189	g_WaitCursorCount: longint;
190
191	procedure SetWaitCursor;
192	begin
193	if g_WaitCursorCount = 0 then
194	Screen.Cursor := crHourGlass;
195
196	inc( g_WaitCursorCount );
197	end;
198
199	procedure ClearWaitCursor;
200	begin
201	if g_WaitCursorCount > 0 then
202	begin
203	dec( g_WaitCursorCount );
204	if g_WaitCursorCount = 0 then
205	begin
206	Screen.Cursor := crDefault;
207	end;
208	end;
209
210	end;
211
212	procedure StartTimer( Timer: TTimer );
213	begin
214	{$ifdef win32}
215	Timer.Enabled := true;
216	{$else}
217	Timer.Start;
218	{$endif}
219	end;
220
221	procedure StopTimer( Timer: TTimer );
222	begin
223	{$ifdef win32}
224	Timer.Enabled := false;
225	{$else}
226	Timer.Stop;
227	{$endif}
228	end;
229
230	{$ifdef win32}
231	procedure SetFocusTo( Control: TWinControl );
232	begin
233	Control.SetFocus;
234	end;
235	{$else}
236	procedure SetFocusTo( Control: TControl );
237	begin
238	Control.Focus;
239	end;
240	{$endif}
241
242	{$ifdef win32}
243	const
244	EndLineStr = #13 +#10;
245
246	Procedure AddBoldedLine( RichEdit: TRichEdit;
247	BoldPart: string;
248	NormalPart: string );
249	var
250	LineStart: integer;
251	Dummy: integer;
252	begin
253	with RichEdit do
254	begin
255	SendMessage( Handle,
256	EM_GETSEL,
257	Longint( Addr( LineStart ) ),
258	Longint( Addr( Dummy ) ) );
259
260	SendMessage( Handle,
261	EM_REPLACESEL,
262	0,
263	Longint(PChar( BoldPart)));
264
265	SelStart:= LineStart;
266	SelLength:= Length( BoldPart );
267	SelAttributes.Style:= [ fsBold ];
268
269	SelStart:= LineStart + Length( BoldPart );
270	SelLength:= 0;
271	SendMessage( Handle,
272	EM_REPLACESEL,
273	0,
274	Longint(PChar( NormalPart)));
275	SelStart:= LineStart + Length( BoldPart );
276	SelLength:= Length( NormalPart );
277	SelAttributes.Style:= [];
278	SelStart:= LineStart + Length( BoldPart )
279	+ Length( NormalPart );
280	SelLength:= 0;
281	SendMessage( Handle,
282	EM_REPLACESEL,
283	0,
284	Longint(PChar( EndLineStr )));
285
286	end;
287
288	end;
289
290	Procedure GetExpandedNodesCumulative( Node: TTreeNode;
291	ExpandedNodeList: TStrings;
292	const Path: string );
293	var
294	SubNode: TTreeNode;
295	begin
296	if Node.Expanded then
297	begin
298	ExpandedNodeList.Add( Path + Node.Text );
299
300	SubNode := Node.getFirstChild;
301	while SubNode <> nil do
302	begin
303	GetExpandedNodesCumulative( SubNode,
304	ExpandedNodeList,
305	Path + Node.Text + '\' );
306	SubNode := SubNode.getNextSibling;
307	end;
308	end;
309	end;
310
311	Procedure GetExpandedNodes( TreeView: TTreeView;
312	ExpandedNodeList: TStrings );
313	begin
314	ExpandedNodeList.Clear;
315	if TreeView.Items.GetFirstNode = nil then
316	exit;
317	GetExpandedNodesCumulative( TreeView.Items.GetFirstNode,
318	ExpandedNodeList,
319	'' );
320	end;
321
322	{$endif}
323
324	function InvertRGB( Arg: TColor ): TColor;
325	begin
326	{$ifdef os2}
327	Result:= SysColorToRGB( Arg ); // in case it's a system color e.g. button face
328	{$endif}
329	{$ifdef win32}
330	Result := ColorToRGB( Arg );
331	{$endif}
332	Result:= Result xor $ffffff; // now invert the RGB components
333	end;
334
335	function GetScreenColorDepth: longint;
336	var
337	DeviceContext: HDC;
338	begin
339	{$ifdef os2}
340	// OS/2
341	DeviceContext := GpiQueryDevice( Screen.Canvas.Handle );
342	DevQueryCaps( DeviceContext,
343	CAPS_COLOR_BITCOUNT,
344	1,
345	Result );
346	{$endif}
347	{$ifdef win32}
348	// Windows
349	DeviceContext := CreateCompatibleDC( 0 ); // get screen dc
350	Result := GetDeviceCaps( DeviceContext,
351	BITSPIXEL );
352	DeleteDC( DeviceContext );
353	{$endif}
354	end;
355
356	function GetVideoDriverName: string;
357	{$ifdef os2}
358	var
359	BaseDisplayDriverName: cstring;
360	GraddChains: string;
361	GraddDriverName: string;
362	{$endif}
363	begin
364	{$ifdef os2}
365	// Get the PM display driver name from OS2.ini (strangely, NOT os2sys.ini).
366	PrfQueryProfileString( HINI_USERPROFILE, // OS2 INI
367	'PM_DISPLAYDRIVERS', // app
368	'CURRENTDRIVER', // key
369	'Unknown Display Driver', // default
370	BaseDisplayDriverName,
371	sizeof( BaseDisplayDriverName ) );
372
373	if BaseDisplayDriverName <> 'GRE2VMAN' then
374	begin
375	// non-gradd (old style) driver.
376	Result := BaseDisplayDriverName;
377	exit;
378	end;
379
380	// it's a GRADD driver
381	// Get the GRADD_CHAINS environment variable, this tells us
382	// where to look for more info...
383	GraddChains := GetEnv( 'GRADD_CHAINS' );
384	if GraddChains = '' then
385	begin
386	Result := 'Unknown GRADD driver (GRADD_CHAINS not set)';
387	exit;
388	end;
389
390	// OK, now get the environment variable GRADD_CHAINS refers to...
391	GraddDriverName := GetEnv( GraddChains );
392	if GraddDriverName = '' then
393	begin
394	Result := 'Unknown GRADD driver (GRADD_CHAINS: '
395	+ GraddChains
396	+ ' returns blank)';
397	exit;
398	end;
399
400	// Normal GRADD case
401	Result := 'GRADD: '
402	+ GraddDriverName;
403
404	// if sddgradd then ...?
405	{$endif}
406	end;
407
408	procedure SmartSetWindowPos( Form: TForm;
409	X, Y, W, H: longint;
410	Maximised: boolean );
411	begin
412	{$ifdef os2}
413	if Form.Handle = 0 then
414	begin
415	// window not yet created, set the position for restore then maximize
416	Form.SetWindowPos( X, Y, W, H );
417	if Maximised then
418	Form.WindowState := wsMaximized;
419	exit;
420	end;
421
422	// window already created
423
424	if Form.WindowState = wsMaximized then
425	begin
426	// window already maximized, so set the restore position in window USHORTs
427	WinSetWindowUShort( Form.Frame.Handle, QWS_XRESTORE, X );
428	WinSetWindowUShort( Form.Frame.Handle, QWS_YRESTORE, Y );
429	WinSetWindowUShort( Form.Frame.Handle, QWS_CXRESTORE, W );
430	WinSetWindowUShort( Form.Frame.Handle, QWS_CYRESTORE, H );
431
432	// And reposition in maximized state
433	X := 0;
434	Y := 0;
435
436	if Form.Parent = nil then
437	begin
438	W := Screen.Width;
439	H := Screen.Height;
440	end
441	else
442	begin
443	W := Form.Parent.ClientWidth;
444	H := Form.Parent.ClientHeight;
445	end;
446
447	// We enlarge the area used so that the border is off screen.
448	if Form.BorderStyle <> bsNone then
449	begin
450	dec( X, GetBorderWidth( Form ) );
451	dec( Y, GetBorderHeight( Form ) );
452	inc( W, GetBorderWidth( Form ) * 2 );
453	inc( H, GetBorderHeight( Form ) * 2 );
454	end;
455	Form.SetWindowPos( X, Y, W, H );
456	end
457	else
458	begin
459	// Window not currently maximized
460	Form.SetWindowPos( X, Y, W, H );
461	if Maximised then
462	Form.WindowState := wsMaximized;
463	end;
464	{$else}
465	// set the position for restore then maximize
466	Form.Left := X;
467	Form.Top := Y;
468	Form.Width := W;
469	Form.Height := H;
470	if Maximised then
471	Form.WindowState := wsMaximized;
472	{$endif}
473	end;
474
475	procedure SmartGetWindowPos( Form: TForm;
476	Var X, Y, W, H: longint;
477	Var Maximised: boolean );
478	{$ifdef win32}
479	var
480	Placement: WINDOWPLACEMENT;
481	{$endif}
482	begin
483	X := Form.Left;
484	{$ifdef os2}
485	Y := Form.Bottom;
486	{$else}
487	Y := Form.Top;
488	{$endif}
489	W := Form.Width;
490	H := Form.Height;
491	Maximised := Form.WindowState = wsMaximized;
492	if Form.Handle = 0 then
493	begin
494	// window not yet created, so we are done.
495	exit;
496	end;
497
498	// window already created
499
500	{$ifdef os2}
501	if Form.WindowState in [ wsMaximized, wsMinimized ] then
502	begin
503	// window already maximized, so get the restore position from window USHORTs
504	X := WinQueryWindowUShort( Form.Frame.Handle, QWS_XRESTORE );
505	Y := WinQueryWindowUShort( Form.Frame.Handle, QWS_YRESTORE );
506	W := WinQueryWindowUShort( Form.Frame.Handle, QWS_CXRESTORE );
507	H := WinQueryWindowUShort( Form.Frame.Handle, QWS_CYRESTORE );
508	end;
509	{$endif}
510	{$ifdef win32}
511	// get normal position
512	Placement.length := sizeof( Placement );
513	GetWindowPlacement( Form.Handle, @Placement );
514	X := Placement.rcNormalPosition.Left;
515	Y := Placement.rcNormalPosition.Top;
516	W := Placement.rcNormalPosition.Right - Placement.rcNormalPosition.Left;
517	H := Placement.rcNormalPosition.Bottom - Placement.rcNormalPosition.Top;
518	{$endif}
519	end;
520
521	Procedure SaveFormSizePosition( Form: TForm;
522	IniFile: TMyIniFile );
523	Var
524	Maximised: boolean;
525	X: longint;
526	Y: longint;
527	W: longint;
528	H: longint;
529	Section: string;
530	Begin
531	Section := Form.Name;
532
533	SmartGetWindowPos( Form, X, Y, W, H, Maximised );
534
535	IniFile.WriteInteger( Section,
536	'X',
537	X );
538	IniFile.WriteInteger( Section,
539	'Y',
540	Y );
541	IniFile.WriteInteger( Section,
542	'Width',
543	W );
544	IniFile.WriteInteger( Section,
545	'Height',
546	H );
547
548	IniFile.WriteBool( Section,
549	'Maximised',
550	Maximised );
551	End;
552
553	Procedure LoadFormSizePosition( Form: TForm;
554	IniFile: TMyIniFile );
555	Var
556	Maximised: boolean;
557	X: longint;
558	Y: longint;
559	W: longint;
560	H: longint;
561	Section: string;
562	Begin
563	Section := Form.Name;
564
565	X := IniFile.ReadInteger( Section,
566	'X',
567	Form.Left );
568	Y := IniFile.ReadInteger( Section,
569	'Y',
570	{$ifdef os2}
571	Form.Bottom );
572	{$else}
573	Form.Top );
574	{$endif}
575	W := IniFile.ReadInteger( Section,
576	'Width',
577	Form.Width );
578	H := IniFile.ReadInteger( Section,
579	'Height',
580	Form.Height );
581
582	Maximised := IniFile.ReadBool( Section,
583	'Maximised',
584	Form.WindowState = wsMaximized );
585	SmartSetWindowPos( Form, X, Y, W, H, Maximised );
586
587	End;
588
589	Function SelectedObject( ListBox: TListBox ): TObject;
590	begin
591	if ( ListBox.ItemIndex >= 0 )
592	and ( ListBox.ItemIndex < ListBox.Items.Count ) then
593	Result:= ListBox.Items.Objects[ ListBox.ItemIndex ]
594	else
595	Result:= nil;
596	end;
597
598	Procedure SetSelectedByObject( ListBox: TListBox;
599	SelectObject: TObject );
600	var
601	Index: integer;
602	begin
603	Index := ListBox.Items.IndexOfObject( SelectObject );
604	ListBox.ItemIndex := Index;
605	end;
606
607	Function SelectedItem( ListBox: TListBox ): string;
608	begin
609	if ( ListBox.ItemIndex >= 0 )
610	and ( ListBox.ItemIndex < ListBox.Items.Count ) then
611	Result:= ListBox.Items[ ListBox.ItemIndex ]
612	else
613	Result:= '';
614	end;
615
616	Procedure GetSelectedItems( ListBox: TListBox;
617	Dest: TStrings );
618	var
619	i: integer;
620	begin
621	for i:= 0 to ListBox.Items.Count - 1 do
622	if ListBox.Selected[ i ] then
623	Dest.AddObject( ListBox.Items[ i ],
624	ListBox.Items.Objects[ i ] );
625	end;
626
627	{$ifdef os2}
628
629	procedure ScaleChildren( Control: TControl;
630	ScalePosition: boolean;
631	XFactor: double;
632	YFactor: double );
633	forward;
634
635	Procedure ScaleControl( Control: TControl;
636	ScalePosition: boolean;
637	XFactor: double;
638	YFactor: double );
639	var
640	SizeX: boolean;
641	SizeY: boolean;
642	begin
643	SizeX := true;
644	SizeY := true;
645
646	if Control is TEdit then
647	if TEdit( Control ).AutoSize then
648	SizeY := false;
649
650	if Control is TLabel then
651	begin
652	if TLabel( Control ).AutoSize then
653	begin
654	SizeX := false;
655	SizeY := false;
656	end;
657	end;
658
659	if SizeX then
660	Control.ClientWidth := Round( Control.ClientWidth * XFactor );
661
662	if SizeY then
663	Control.ClientHeight := Round( Control.ClientHeight * YFactor );
664
665	if ScalePosition then
666	begin
667	Control.Left := Round( Control.Left * XFactor );
668	Control.Bottom := Round( Control.Bottom * YFactor );
669	end;
670
671	if Control is TTabbedNotebook then
672	// size the tabset to match
673	TTabbedNotebook( Control ).TabHeight :=
674	Round( TTabbedNotebook( Control ).TabHeight * YFactor );
675
676	if Control is TMultiColumnListBox then
677	TMultiColumnListBox( Control ).HeaderHeight :=
678	Round( TMultiColumnListBox( Control ).HeaderHeight * YFactor );
679
680	if csDetail in Control.ComponentState then
681	exit;
682	if not ( csAcceptsControls in Control.ComponentState ) then
683	exit;
684
685	ScaleChildren( Control,
686	ScalePosition,
687	XFactor,
688	YFactor );
689	end;
690
691	procedure ScaleChildren( Control: TControl;
692	ScalePosition: boolean;
693	XFactor: double;
694	YFactor: double );
695	var
696	i: longint;
697	Child: TControl;
698	begin
699	for i := 0 to Control.ControlCount do
700	begin
701	Child := Control.Controls[ i ];
702	if Child = nil then
703	continue;
704
705	if Control is TTabbedNotebook then
706	begin
707	if Child is TTabSet then
708	// tabset sized elsewhere
709	continue;
710
711	if Child is TNotebook then
712	begin
713	// notebook has been sized as part of TTabbedNotebook
714	ScaleChildren( Child, true, XFactor, YFactor );
715	continue;
716	end;
717
718	end;
719
720	if Child is TPage then
721	begin
722	// Only size children, notebook has sized page
723	ScaleChildren( Child, true, XFactor, YFactor );
724	continue;
725	end;
726
727	ScaleControl( Child,
728	true,
729	XFactor,
730	YFactor );
731	end;
732	end;
733
734	Function AdjustFactor( Factor: double ): double;
735	begin
736	if Factor <= 1.0 then
737	result := Factor
738	else if ( Factor > 1.0 ) and ( Factor < 1.2 ) then
739	result := 1.0
740	else
741	result := Factor - 0.2;
742
743	end;
744
745	var
746	ScaledForms: TList;
747
748	Procedure ScaleForm( Form: TForm;
749	OriginalFontWidth: longint;
750	OriginalFontHeight: longint );
751	var
752	XFactor: double;
753	YFactor: double;
754	UseWidth: double;
755	UseHeight: double;
756	begin
757	if ScaledForms.IndexOf( Form ) <> -1 then
758	// already scaled this form.
759	exit;
760	ScaledForms.Add( Form );
761
762	UseWidth := Form.Canvas.TextWidth( 'M' );
763	UseHeight := Form.Canvas.TextHeight( 'M' );
764
765	XFactor := AdjustFactor( UseWidth / OriginalFontWidth );
766	YFactor := AdjustFactor( UseHeight / OriginalFontHeight );
767
768	if ( XFactor = 1.0 )
769	and ( YFactor = 1.0 ) then
770	// no scaling to do, skip it for efficiency
771	exit;
772
773	ScaleControl( Form,
774	false,
775	XFactor,
776	YFactor );
777
778	end;
779
780	// Validate component memory and its owned components
781	procedure ValidateComponent( Component: TComponent );
782	var
783	i: longint;
784	begin
785	CheckMem( Component );
786	for i := 0 to Component.ComponentCount - 1 do
787	ValidateComponent( Component.Components[ i ] );
788	end;
789
790	// Validate all known SPCC components
791	procedure ValidateSPCCObjects;
792	var
793	i: longint;
794	Form: TForm;
795	begin
796	CheckHeap;
797
798	ValidateComponent( Screen );
799	ValidateComponent( ClipBoard );
800	for i := 0 to Screen.FormCount - 1 do
801	begin
802	Form := Screen.Forms[ i ];
803	ValidateComponent( Form );
804	end;
805	end;
806
807	Function GetSystemInfoItem( Item: ULONG ): ULONG;
808	begin
809	DosQuerySysInfo( Item,
810	Item,
811	Result,
812	sizeof( Result ) );
813	end;
814
815	Procedure LogException( E: Exception;
816	const LogFileName: string;
817	const Title: string;
818	const AppVersion: string;
819	var F: TextFile );
820	var
821	i: integer;
822	OSMajorVersion: ULONG;
823	OSMinorVersion: ULONG;
824	OSRevision: ULONG;
825	RamMB: ULONG;
826	BootDrive: ULONG;
827	begin
828	AssignFile( F, LogFilename );
829	FileMode := fmInOut;
830
831	try
832	if FileExists( LogFilename ) then
833	Append( F )
834	else
835	Rewrite( F );
836	except
837	exit;
838	end;
839
840	try
841	WriteLn( F, '' );
842	WriteLn( F, '---- ' + Title + ' crash log ----' );
843	WriteLn( F, 'App Version: ' + AppVersion );
844	WriteLn( F, 'Components Version: ' + GetComponentsVersion );
845	WriteLn( F, 'Library Version: ' + GetACLLibraryVersion );
846	WriteLn( F, '' );
847	WriteLn( F, 'Running as process: ' + GetApplicationFilename );
848	WriteLn( F, FormatDateTime( 'd mmmm yyyy, hh:mm:ss', now ) );
849	WriteLn( F, 'Exception type: ' + E.ClassName );
850	WriteLn( F, 'Description: ' + E.Message );
851	WriteLn( F, 'Location: $'
852	+ IntToHex( longword( E.ExcptAddr ), 8 ) );
853
854	WriteLn( F, 'Callstack:' );
855
856	for i := 0 to GetExceptionCallCount - 1 do
857	begin
858	WriteLn( F, ' $' + IntToHex( GetExceptionCallstackEntry( i ), 8 ) );
859	end;
860
861	OSMajorVersion := GetSystemInfoItem( QSV_VERSION_MAJOR );
862	OSMinorVersion := GetSystemInfoItem( QSV_VERSION_MINOR );
863	OSRevision := GetSystemInfoItem( QSV_VERSION_REVISION );
864
865	WriteLn( F, 'System version:'
866	+ IntToStr( OSMajorVersion )
867	+ '.'
868	+ IntToStr( OSMinorVersion )
869	+ '.'
870	+ IntToStr( OSRevision ) );
871	if OSMajorVersion = 20 then
872	begin
873	case OSMinorVersion of
874	00: WriteLn( F, ' OS/2 2.0' );
875	10: WriteLn( F, ' OS/2 2.1' );
876	11: WriteLn( F, ' OS/2 2.11' );
877	30: WriteLn( F, ' OS/2 3.0' );
878	40: WriteLn( F, ' OS/2 4.0' );
879	45: WriteLn( F, ' OS/2 4.5' ); // I guess
880	end;
881	end;
882
883	RamMB := GetSystemInfoItem( QSV_TOTPHYSMEM )
884	div ( 1024 * 1024 );
885	WriteLn( F, 'RAM: '
886	+ IntToStr( RamMB )
887	+ ' MB' );
888
889	BootDrive := GetSystemInfoItem( QSV_BOOT_DRIVE ); // nA = 1
890	WriteLn( F, 'Boot drive: '
891	+ Chr( Ord( 'A' )
892	+ BootDrive - 1 ) );
893
894	// Video information
895	WriteLn( F, 'Video resolution: '
896	+ IntToStr( Screen.Width )
897	+ 'x'
898	+ IntToStr( Screen.Height ) );
899	WriteLn( F, 'Color depth: '
900	+ IntToStr( GetScreenColorDepth )
901	+ ' bits' );
902	WriteLn( F, 'Video driver: '
903	+ GetVideoDriverName );
904	except
905	end;
906
907	end;
908
909	Function FindTopFormWindow( const WindowClassName: string ): HWND;
910	var
911	EnumHandle: HENUM;
912	ChildEnumHandle: HENUM;
913	Child: HWND;
914
915	Buffer: array[ 0..31 ] of char;
916	FrameClassName: array[ 0..31 ] of char;
917	MyClassName: array[ 0..31 ] of char;
918	Len: longint;
919	FrameClassConst: longint;
920	Found: boolean;
921	begin
922	FrameClassConst := WC_FRAME;
923	StrPCopy( FrameClassName, '#' + IntToStr( USHORT( FrameClassConst ) ) );
924	StrPCopy( MyClassName, WindowClassName );
925
926	// first enum desktop children to find Frame windows
927	EnumHandle := WinBeginEnumWindows( HWND_DESKTOP );
928	while true do
929	begin
930	result := WinGetNextWindow( EnumHandle );
931	if result = NULLHANDLE then
932	// ran out
933	break;
934
935	Len := WinQueryClassName( result, sizeof( Buffer ), Buffer );
936	Buffer[ Len ] := #0;
937	if StrLComp( Buffer, FrameClassName, sizeof( Buffer ) ) = 0 then
938	begin
939	// this is a WC_FRAME window
940	// look thru it's children for the form name we want...
941
942	ChildEnumHandle := WinBeginEnumWindows( result );
943
944	Found := false;
945	while true do
946	begin
947	Child := WinGetNextWindow( ChildEnumHandle );
948	if Child = NULLHANDLE then
949	break;
950
951	Len := WinQueryClassName( Child, sizeof( Buffer ), Buffer );
952	if StrLComp( Buffer, MyClassName, sizeof( Buffer ) ) = 0 then
953	begin
954	// found
955	Found := true;
956	break;
957	end;
958	end;
959	WinEndEnumWindows( ChildEnumHandle );
960	if Found then
961	break;
962	end;
963	end;
964	WinEndEnumWindows( EnumHandle );
965	end;
966
967	Function GetLinkCursor: TCursor;
968	begin
969	Result := TheLinkCursor;
970	end;
971	{$endif}
972
973	const
974	LibVersion = 'v1.11.26'; // // $SS_REQUIRE_NEW_VERSION$
975
976	function GetComponentsVersion: string;
977	begin
978	Result := LibVersion;
979	end;
980
981	{$ifdef os2}
982	Initialization
983	ScaledForms := TList.Create;
984
985	TheLinkPointer := TPointer.Create;
986	TheLinkPointer.LoadFromResourceName( 'LinkPointer' );
987	TheLinkCursor := Screen.AddCursor( TheLinkPointer.Handle );
988
989	Finalization
990	ScaledForms.Destroy;
991	TheLinkPointer.Destroy;
992	{$endif}
993	end.

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

Download in other formats: