Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

ControlsUtility.pas

Last change on this file was 490, checked in by ataylor, 20 months ago
Account for taller titlebar when rescaling forms.
Property svn:eol-style set to `native`
File size: 25.3 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, ExtCtrls,
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	// TRadioGroup seems to handle its own children automatically
681	if Control is TRadioGroup then
682	exit;
683	if csDetail in Control.ComponentState then
684	exit;
685	if not ( csAcceptsControls in Control.ComponentState ) then
686	exit;
687
688	ScaleChildren( Control,
689	ScalePosition,
690	XFactor,
691	YFactor );
692	end;
693
694	procedure ScaleChildren( Control: TControl;
695	ScalePosition: boolean;
696	XFactor: double;
697	YFactor: double );
698	var
699	i: longint;
700	Child: TControl;
701	begin
702	for i := 0 to Control.ControlCount do
703	begin
704	Child := Control.Controls[ i ];
705	if Child = nil then
706	continue;
707
708	if Control is TTabbedNotebook then
709	begin
710	if Child is TTabSet then
711	// tabset sized elsewhere
712	continue;
713
714	if Child is TNotebook then
715	begin
716	// notebook has been sized as part of TTabbedNotebook
717	ScaleChildren( Child, true, XFactor, YFactor );
718	continue;
719	end;
720
721	end;
722
723	if Child is TPage then
724	begin
725	// Only size children, notebook has sized page
726	ScaleChildren( Child, true, XFactor, YFactor );
727	continue;
728	end;
729
730	ScaleControl( Child,
731	true,
732	XFactor,
733	YFactor );
734	end;
735	end;
736
737	Function AdjustFactor( Factor: double ): double;
738	begin
739	if Factor <= 1.0 then
740	result := Factor
741	else if ( Factor > 1.0 ) and ( Factor < 1.2 ) then
742	result := 1.0
743	else
744	result := Factor - 0.2;
745
746	end;
747
748	var
749	ScaledForms: TList;
750
751	Procedure ScaleForm( Form: TForm;
752	OriginalFontWidth: longint;
753	OriginalFontHeight: longint );
754	var
755	XFactor: double;
756	YFactor: double;
757	UseWidth: double;
758	UseHeight: double;
759	InitW: longint;
760	InitH: longint;
761	TBarHeight: integer;
762	begin
763	InitW := Form.Width;
764	InitH := Form.Height;
765
766	if ScaledForms.IndexOf( Form ) <> -1 then
767	// already scaled this form.
768	exit;
769	ScaledForms.Add( Form );
770
771	UseWidth := Form.Canvas.TextWidth( 'M' );
772	UseHeight := Form.Canvas.TextHeight( 'M' );
773
774	XFactor := AdjustFactor( UseWidth / OriginalFontWidth );
775	YFactor := AdjustFactor( UseHeight / OriginalFontHeight );
776
777	if ( XFactor = 1.0 )
778	and ( YFactor = 1.0 ) then
779	// no scaling to do, skip it for efficiency
780	exit;
781
782	ScaleControl( Form,
783	false,
784	XFactor,
785	YFactor );
786
787	// Increase overall window height to allow for a taller-than-normal titlebar
788	TBarHeight := WinQuerySysValue( HWND_DESKTOP, SV_CYTITLEBAR );
789	if TBarHeight > 23 then
790	//Form.Height := Form.Height + TBarHeight - 23;
791	Form.Height := Form.Height + Round( 23 * YFactor ) - 20;
792
793	// Adjust the bottom left position by half of the width/height increase
794	if Form.Position in [ poDefault, poDefaultPosOnly, poScreenCenter ] then
795	begin
796	Form.Left := Form.Left - (( Form.Width - InitW ) div 2 );
797	Form.Bottom := Form.Bottom - (( Form.Height - InitH ) div 2 );
798	end;
799
800	end;
801
802	// Validate component memory and its owned components
803	procedure ValidateComponent( Component: TComponent );
804	var
805	i: longint;
806	begin
807	CheckMem( Component );
808	for i := 0 to Component.ComponentCount - 1 do
809	ValidateComponent( Component.Components[ i ] );
810	end;
811
812	// Validate all known SPCC components
813	procedure ValidateSPCCObjects;
814	var
815	i: longint;
816	Form: TForm;
817	begin
818	CheckHeap;
819
820	ValidateComponent( Screen );
821	ValidateComponent( ClipBoard );
822	for i := 0 to Screen.FormCount - 1 do
823	begin
824	Form := Screen.Forms[ i ];
825	ValidateComponent( Form );
826	end;
827	end;
828
829	Function GetSystemInfoItem( Item: ULONG ): ULONG;
830	begin
831	DosQuerySysInfo( Item,
832	Item,
833	Result,
834	sizeof( Result ) );
835	end;
836
837	Procedure LogException( E: Exception;
838	const LogFileName: string;
839	const Title: string;
840	const AppVersion: string;
841	var F: TextFile );
842	var
843	i: integer;
844	OSMajorVersion: ULONG;
845	OSMinorVersion: ULONG;
846	OSRevision: ULONG;
847	RamMB: ULONG;
848	BootDrive: ULONG;
849	begin
850	AssignFile( F, LogFilename );
851	FileMode := fmInOut;
852
853	try
854	if FileExists( LogFilename ) then
855	Append( F )
856	else
857	Rewrite( F );
858	except
859	exit;
860	end;
861
862	try
863	WriteLn( F, '' );
864	WriteLn( F, '---- ' + Title + ' crash log ----' );
865	WriteLn( F, 'App Version: ' + AppVersion );
866	WriteLn( F, 'Components Version: ' + GetComponentsVersion );
867	WriteLn( F, 'Library Version: ' + GetACLLibraryVersion );
868	WriteLn( F, '' );
869	WriteLn( F, 'Running as process: ' + GetApplicationFilename );
870	WriteLn( F, FormatDateTime( 'd mmmm yyyy, hh:mm:ss', now ) );
871	WriteLn( F, 'Exception type: ' + E.ClassName );
872	WriteLn( F, 'Description: ' + E.Message );
873	WriteLn( F, 'Location: $'
874	+ IntToHex( longword( E.ExcptAddr ), 8 ) );
875
876	WriteLn( F, 'Callstack:' );
877
878	for i := 0 to GetExceptionCallCount - 1 do
879	begin
880	WriteLn( F, ' $' + IntToHex( GetExceptionCallstackEntry( i ), 8 ) );
881	end;
882
883	OSMajorVersion := GetSystemInfoItem( QSV_VERSION_MAJOR );
884	OSMinorVersion := GetSystemInfoItem( QSV_VERSION_MINOR );
885	OSRevision := GetSystemInfoItem( QSV_VERSION_REVISION );
886
887	WriteLn( F, 'System version:'
888	+ IntToStr( OSMajorVersion )
889	+ '.'
890	+ IntToStr( OSMinorVersion )
891	+ '.'
892	+ IntToStr( OSRevision ) );
893	if OSMajorVersion = 20 then
894	begin
895	case OSMinorVersion of
896	00: WriteLn( F, ' OS/2 2.0' );
897	10: WriteLn( F, ' OS/2 2.1' );
898	11: WriteLn( F, ' OS/2 2.11' );
899	30: WriteLn( F, ' OS/2 3.0' );
900	40: WriteLn( F, ' OS/2 4.0' );
901	45: WriteLn( F, ' OS/2 4.5' ); // I guess
902	end;
903	end;
904
905	RamMB := GetSystemInfoItem( QSV_TOTPHYSMEM )
906	div ( 1024 * 1024 );
907	WriteLn( F, 'RAM: '
908	+ IntToStr( RamMB )
909	+ ' MB' );
910
911	BootDrive := GetSystemInfoItem( QSV_BOOT_DRIVE ); // nA = 1
912	WriteLn( F, 'Boot drive: '
913	+ Chr( Ord( 'A' )
914	+ BootDrive - 1 ) );
915
916	// Video information
917	WriteLn( F, 'Video resolution: '
918	+ IntToStr( Screen.Width )
919	+ 'x'
920	+ IntToStr( Screen.Height ) );
921	WriteLn( F, 'Color depth: '
922	+ IntToStr( GetScreenColorDepth )
923	+ ' bits' );
924	WriteLn( F, 'Video driver: '
925	+ GetVideoDriverName );
926	except
927	end;
928
929	end;
930
931	Function FindTopFormWindow( const WindowClassName: string ): HWND;
932	var
933	EnumHandle: HENUM;
934	ChildEnumHandle: HENUM;
935	Child: HWND;
936
937	Buffer: array[ 0..31 ] of char;
938	FrameClassName: array[ 0..31 ] of char;
939	MyClassName: array[ 0..31 ] of char;
940	Len: longint;
941	FrameClassConst: longint;
942	Found: boolean;
943	begin
944	FrameClassConst := WC_FRAME;
945	StrPCopy( FrameClassName, '#' + IntToStr( USHORT( FrameClassConst ) ) );
946	StrPCopy( MyClassName, WindowClassName );
947
948	// first enum desktop children to find Frame windows
949	EnumHandle := WinBeginEnumWindows( HWND_DESKTOP );
950	while true do
951	begin
952	result := WinGetNextWindow( EnumHandle );
953	if result = NULLHANDLE then
954	// ran out
955	break;
956
957	Len := WinQueryClassName( result, sizeof( Buffer ), Buffer );
958	Buffer[ Len ] := #0;
959	if StrLComp( Buffer, FrameClassName, sizeof( Buffer ) ) = 0 then
960	begin
961	// this is a WC_FRAME window
962	// look thru it's children for the form name we want...
963
964	ChildEnumHandle := WinBeginEnumWindows( result );
965
966	Found := false;
967	while true do
968	begin
969	Child := WinGetNextWindow( ChildEnumHandle );
970	if Child = NULLHANDLE then
971	break;
972
973	Len := WinQueryClassName( Child, sizeof( Buffer ), Buffer );
974	if StrLComp( Buffer, MyClassName, sizeof( Buffer ) ) = 0 then
975	begin
976	// found
977	Found := true;
978	break;
979	end;
980	end;
981	WinEndEnumWindows( ChildEnumHandle );
982	if Found then
983	break;
984	end;
985	end;
986	WinEndEnumWindows( EnumHandle );
987	end;
988
989	Function GetLinkCursor: TCursor;
990	begin
991	Result := TheLinkCursor;
992	end;
993	{$endif}
994
995	const
996	LibVersion = 'v1.11.26'; // // $SS_REQUIRE_NEW_VERSION$
997
998	function GetComponentsVersion: string;
999	begin
1000	Result := LibVersion;
1001	end;
1002
1003	{$ifdef os2}
1004	Initialization
1005	ScaledForms := TList.Create;
1006
1007	TheLinkPointer := TPointer.Create;
1008	TheLinkPointer.LoadFromResourceName( 'LinkPointer' );
1009	TheLinkCursor := Screen.AddCursor( TheLinkPointer.Handle );
1010
1011	Finalization
1012	ScaledForms.Destroy;
1013	TheLinkPointer.Destroy;
1014	{$endif}
1015	end.

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

Context Navigation

source: trunk/Components/ControlsUtility.pas

Download in other formats: