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
RevLine 
[15]1unit ControlsUtility;
2
3interface
4
5uses
6 Classes, StdCtrls, SysUtils,
[457]7 ACLUtility, StringUtilsUnit,
[15]8{$ifdef win32}
9 ExtCtrls, Forms, Controls, ComCtrls, Windows, Messages, Graphics;
10{$else}
11 OS2Def, Forms;
12{$endif}
13
14const
15{$ifdef win32}
16 Mnem = '&';
17{$else}
18 Mnem = '~';
19{$endif}
20
21function GetComponentsVersion: string;
22
23function InvertRGB( Arg: TColor ): TColor;
24
25function GetScreenColorDepth: longint;
26function GetVideoDriverName: string;
27
28procedure SmartGetWindowPos( Form: TForm;
29 Var X, Y, W, H: longint;
30 Var Maximised: boolean );
31
32procedure SmartSetWindowPos( Form: TForm;
33 X, Y, W, H: longint;
34 Maximised: boolean );
35
36// Load/save form to inifile
37Procedure SaveFormSizePosition( Form: TForm;
38 IniFile: TMyIniFile );
39Procedure LoadFormSizePosition( Form: TForm;
40 IniFile: TMyIniFile );
41
42{$ifdef os2}
43// Utility access to the link (hand) cursor
44Function GetLinkCursor: TCursor;
45
46// set a wait cursor. If already set, increments a count
47procedure SetWaitCursor;
48
49// clear wait cursor. Only actually clears it if the count is now 0.
50procedure ClearWaitCursor;
51
52function GetNiceDefaultFont: TFont;
53{$endif}
54
55procedure StartTimer( Timer: TTimer );
56procedure StopTimer( Timer: TTimer );
57
58// Listbox utility functions
59Function SelectedObject( ListBox: TListBox ): TObject;
60Procedure SetSelectedByObject( ListBox: TListBox;
61 SelectObject: TObject );
62Function SelectedItem( ListBox: TListBox ): string;
63Procedure GetSelectedItems( ListBox: TListBox;
64 Dest: TStrings );
65
66{$ifdef win32}
67procedure SetFocusTo( Control: TWinControl );
68{$else}
69procedure SetFocusTo( Control: TControl );
70{$endif}
71
72{$ifdef win32}
73Procedure AddBoldedLine( RichEdit: TRichEdit;
74 BoldPart: string;
75 NormalPart: string );
76
77Procedure GetExpandedNodes( TreeView: TTreeView;
78 ExpandedNodeList: TStrings );
79
80{$endif}
81
82{$ifdef os2}
83Procedure 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)
90procedure ValidateSPCCObjects;
91
92Procedure 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
99Function FindTopFormWindow( const WindowClassName: string ): HWND;
100
101{$endif}
102
103
104implementation
105
106{$ifdef os2}
107uses
108 PMGpi, PMDev, PMShl, DOS, PMWin, BseDos,
109 TabCtrls,
110 MultiColumnListBox,
111 Graphics;
112
113{$R ControlsUtility}
114
115Var
116 TheLinkCursor: TCursor; // loaded on unit initialisation.
117 TheLinkPointer: TPointer; // loaded on unit initialisation.
118
119function GetNiceDefaultFont: TFont;
120var
121 OverrideAppFontName: string;
122 OverrideAppFontSize: string;
[457]123 WindowTextFont: string;
124 DefaultFontFromIni: cstring;
125 DotPos: integer;
[15]126begin
127 // For Marco!
128 OverrideAppFontName := GetEnv( 'ACL_OVERRIDE_FONT_NAME' );
129 OverrideAppFontSize := GetEnv( 'ACL_OVERRIDE_FONT_SIZE' );
130
[457]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
[15]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;
185end;
186{$endif}
187
188var
189 g_WaitCursorCount: longint;
190
191procedure SetWaitCursor;
192begin
193 if g_WaitCursorCount = 0 then
194 Screen.Cursor := crHourGlass;
195
196 inc( g_WaitCursorCount );
197end;
198
199procedure ClearWaitCursor;
200begin
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
210end;
211
212procedure StartTimer( Timer: TTimer );
213begin
214{$ifdef win32}
215 Timer.Enabled := true;
216{$else}
217 Timer.Start;
218{$endif}
219end;
220
221procedure StopTimer( Timer: TTimer );
222begin
223{$ifdef win32}
224 Timer.Enabled := false;
225{$else}
226 Timer.Stop;
227{$endif}
228end;
229
230{$ifdef win32}
231procedure SetFocusTo( Control: TWinControl );
232begin
233 Control.SetFocus;
234end;
235{$else}
236procedure SetFocusTo( Control: TControl );
237begin
238 Control.Focus;
239end;
240{$endif}
241
242{$ifdef win32}
243const
244 EndLineStr = #13 +#10;
[457]245
[15]246Procedure AddBoldedLine( RichEdit: TRichEdit;
247 BoldPart: string;
248 NormalPart: string );
249var
250 LineStart: integer;
251 Dummy: integer;
252begin
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
288end;
289
290Procedure GetExpandedNodesCumulative( Node: TTreeNode;
291 ExpandedNodeList: TStrings;
292 const Path: string );
293var
294 SubNode: TTreeNode;
295begin
296 if Node.Expanded then
297 begin
298 ExpandedNodeList.Add( Path + Node.Text );
[457]299
[15]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;
309end;
310
311Procedure GetExpandedNodes( TreeView: TTreeView;
312 ExpandedNodeList: TStrings );
313begin
314 ExpandedNodeList.Clear;
315 if TreeView.Items.GetFirstNode = nil then
316 exit;
317 GetExpandedNodesCumulative( TreeView.Items.GetFirstNode,
318 ExpandedNodeList,
319 '' );
320end;
321
322{$endif}
323
324function InvertRGB( Arg: TColor ): TColor;
325begin
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
333end;
334
335function GetScreenColorDepth: longint;
336var
337 DeviceContext: HDC;
338begin
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}
354end;
355
356function GetVideoDriverName: string;
357{$ifdef os2}
358var
359 BaseDisplayDriverName: cstring;
360 GraddChains: string;
361 GraddDriverName: string;
362{$endif}
363begin
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}
406end;
407
408procedure SmartSetWindowPos( Form: TForm;
409 X, Y, W, H: longint;
410 Maximised: boolean );
411begin
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}
473end;
474
475procedure SmartGetWindowPos( Form: TForm;
476 Var X, Y, W, H: longint;
477 Var Maximised: boolean );
478{$ifdef win32}
479var
480 Placement: WINDOWPLACEMENT;
481{$endif}
482begin
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}
519end;
520
521Procedure SaveFormSizePosition( Form: TForm;
522 IniFile: TMyIniFile );
523Var
524 Maximised: boolean;
525 X: longint;
526 Y: longint;
527 W: longint;
528 H: longint;
529 Section: string;
530Begin
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 );
551End;
552
553Procedure LoadFormSizePosition( Form: TForm;
554 IniFile: TMyIniFile );
555Var
556 Maximised: boolean;
557 X: longint;
558 Y: longint;
559 W: longint;
560 H: longint;
561 Section: string;
562Begin
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
587End;
588
589Function SelectedObject( ListBox: TListBox ): TObject;
590begin
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;
596end;
597
598Procedure SetSelectedByObject( ListBox: TListBox;
599 SelectObject: TObject );
600var
601 Index: integer;
602begin
603 Index := ListBox.Items.IndexOfObject( SelectObject );
604 ListBox.ItemIndex := Index;
605end;
606
607Function SelectedItem( ListBox: TListBox ): string;
608begin
609 if ( ListBox.ItemIndex >= 0 )
610 and ( ListBox.ItemIndex < ListBox.Items.Count ) then
611 Result:= ListBox.Items[ ListBox.ItemIndex ]
612 else
613 Result:= '';
614end;
615
616Procedure GetSelectedItems( ListBox: TListBox;
617 Dest: TStrings );
618var
619 i: integer;
620begin
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 ] );
625end;
626
627{$ifdef os2}
628
629procedure ScaleChildren( Control: TControl;
630 ScalePosition: boolean;
631 XFactor: double;
632 YFactor: double );
633 forward;
634
635Procedure ScaleControl( Control: TControl;
636 ScalePosition: boolean;
637 XFactor: double;
638 YFactor: double );
639var
640 SizeX: boolean;
641 SizeY: boolean;
642begin
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 );
689end;
690
691procedure ScaleChildren( Control: TControl;
692 ScalePosition: boolean;
693 XFactor: double;
694 YFactor: double );
695var
696 i: longint;
697 Child: TControl;
698begin
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;
732end;
733
734Function AdjustFactor( Factor: double ): double;
735begin
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
743end;
744
745var
746 ScaledForms: TList;
747
748Procedure ScaleForm( Form: TForm;
749 OriginalFontWidth: longint;
750 OriginalFontHeight: longint );
751var
752 XFactor: double;
753 YFactor: double;
754 UseWidth: double;
755 UseHeight: double;
756begin
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
778end;
779
[457]780// Validate component memory and its owned components
[15]781procedure ValidateComponent( Component: TComponent );
782var
783 i: longint;
784begin
785 CheckMem( Component );
786 for i := 0 to Component.ComponentCount - 1 do
787 ValidateComponent( Component.Components[ i ] );
788end;
789
790// Validate all known SPCC components
791procedure ValidateSPCCObjects;
792var
793 i: longint;
794 Form: TForm;
795begin
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;
805end;
806
807Function GetSystemInfoItem( Item: ULONG ): ULONG;
808begin
809 DosQuerySysInfo( Item,
810 Item,
811 Result,
812 sizeof( Result ) );
813end;
814
815Procedure LogException( E: Exception;
816 const LogFileName: string;
817 const Title: string;
818 const AppVersion: string;
819 var F: TextFile );
820var
821 i: integer;
822 OSMajorVersion: ULONG;
823 OSMinorVersion: ULONG;
824 OSRevision: ULONG;
825 RamMB: ULONG;
826 BootDrive: ULONG;
827begin
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
907end;
908
909Function FindTopFormWindow( const WindowClassName: string ): HWND;
910var
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;
921begin
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 );
965end;
966
967Function GetLinkCursor: TCursor;
968begin
969 Result := TheLinkCursor;
970end;
971{$endif}
972
973const
974 LibVersion = 'v1.11.26'; // // $SS_REQUIRE_NEW_VERSION$
975
976function GetComponentsVersion: string;
977begin
978 Result := LibVersion;
979end;
980
981{$ifdef os2}
982Initialization
983 ScaledForms := TList.Create;
984
985 TheLinkPointer := TPointer.Create;
986 TheLinkPointer.LoadFromResourceName( 'LinkPointer' );
987 TheLinkCursor := Screen.AddCursor( TheLinkPointer.Handle );
988
989Finalization
990 ScaledForms.Destroy;
991 TheLinkPointer.Destroy;
992{$endif}
993end.
Note: See TracBrowser for help on using the repository browser.