paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-17 22:09:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: added ExceptProc to forms.pp

Browse Source 
git-svn-id: trunk@380 -
This commit is contained in:
lazarus 2001-10-31 22:12:12 +00:00
parent 90519840bf
commit 0c36e4eab1
2 changed files with 20 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
lcl/forms.pp
View File

@ -23,8 +23,6 @@
***************************************************************************/
}
unit Forms;
@ -257,8 +255,6 @@ type
procedure Idle;
procedure MouseIdle(const CurrentControl: TControl);
procedure SetIcon(AValue: TIcon);
procedure ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@ -317,10 +313,23 @@ implementation
uses
buttons,stdctrls,interfaces,lresources {,designer};
Buttons, StdCtrls, Interfaces, LResources {,designer};
const
FocusMessages : Boolean = true;
procedure ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer);
var
FocusMessages : Boolean; //Should set it to TRUE by defualt but fpc does not handle that yet.
Mess : String;
Begin
Mess := 'Error occurred at '#13#10'Address '+HexStr(Cardinal(Addr),8);
if Application<>nil then
Application.MessageBox('Exception',PChar(Mess),mb_IconError+mb_Ok)
else
writeln(Mess);
end;
function KeysToShiftState(Keys:Word): TShiftState;
begin

15
lcl/include/application.inc
View File

@ -2,6 +2,7 @@
TApplication
******************************************************************************)
{------------------------------------------------------------------------------}
{ TApplication Constructor }
{------------------------------------------------------------------------------}
@ -16,7 +17,7 @@ begin
FIcon := nil;
inherited Create(AOwner);
// RaiseProc := @ExceptionOccurred;
ExceptProc := @ExceptionOccurred;
end;
{------------------------------------------------------------------------------}
@ -298,18 +299,12 @@ begin
end;
end;
procedure TApplication.ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer);
var
Mess : String;
Begin
Mess := 'Error occurred at '#13#10'Address '+inttostr(longint(addr));
MessageBox('Exception',pchar(Mess),mb_IconError+mb_Ok);
end;
{ =============================================================================
$Log$
Revision 1.10 2001/10/31 22:12:12 lazarus
MG: added ExceptProc to forms.pp
Revision 1.9 2001/10/31 21:43:29 lazarus
Added code for TApplication to get it ready to accept exceptions.
Shane