mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-22 09:39:31 +02:00
MG: added TApplication.ShowException
git-svn-id: trunk@490 -
This commit is contained in:
lazarus
parent
e4f93900e6
commit
bd75d3d4c3
89
lcl/forms.pp
89
lcl/forms.pp
@ -260,51 +260,56 @@ type
|
||||
property Width : Integer read GetWidth;
|
||||
end;
|
||||
|
||||
TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
|
||||
TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
|
||||
|
||||
TApplication = class(TComponent)
|
||||
private
|
||||
FHandle : THandle;
|
||||
FIcon: TIcon;
|
||||
FList: TList;
|
||||
FMainForm : TForm;
|
||||
FMouseControl: TControl;
|
||||
FOnIdle: TIdleEvent;
|
||||
FTerminate : Boolean;
|
||||
// MWE:Do we need this ??
|
||||
// function ProcessMessage(Var Msg : TMsg) : Boolean;
|
||||
procedure wndproc(var Message : TLMessage);
|
||||
//the following is used for Messagebox button clicks. Temporary until I figure out a better way.
|
||||
procedure DefaultOnClick(Sender : TObject);
|
||||
//----
|
||||
function GetExename: String;
|
||||
function GetIconHandle: HICON;
|
||||
procedure IconChanged(Sender: TObject);
|
||||
procedure Idle;
|
||||
procedure MouseIdle(const CurrentControl: TControl);
|
||||
procedure SetIcon(AValue: TIcon);
|
||||
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure ControlDestroyed(AControl: TControl);
|
||||
Procedure BringToFront;
|
||||
procedure CreateForm(NewForm : TFormClass; var ref);
|
||||
procedure HandleMessage;
|
||||
procedure HintMouseMEssage(Control : TControl; var Message: TLMessage);
|
||||
property Icon: TIcon read FIcon write SetIcon;
|
||||
procedure Initialize;
|
||||
function MessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
|
||||
procedure Notification(AComponent : TComponent; Operation : TOperation); override;
|
||||
Procedure ProcessMessages;
|
||||
procedure Run;
|
||||
procedure Terminate;
|
||||
property Exename: String read GetExeName;
|
||||
property Handle: THandle read FHandle;
|
||||
property Terminated: Boolean read FTerminate;
|
||||
property MainForm: TForm read FMainForm;
|
||||
property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
|
||||
end;
|
||||
private
|
||||
FHandle : THandle;
|
||||
FIcon: TIcon;
|
||||
FList: TList;
|
||||
FMainForm : TForm;
|
||||
FMouseControl: TControl;
|
||||
FOnException: TExceptionEvent;
|
||||
FOnIdle: TIdleEvent;
|
||||
FTerminate : Boolean;
|
||||
// MWE:Do we need this ??
|
||||
// function ProcessMessage(Var Msg : TMsg) : Boolean;
|
||||
procedure wndproc(var Message : TLMessage);
|
||||
// Shane: the following is used for Messagebox button clicks. Temporary until I figure out a better way.
|
||||
procedure DefaultOnClick(Sender : TObject);
|
||||
//----
|
||||
function GetExename: String;
|
||||
function GetIconHandle: HICON;
|
||||
function GetTitle: string;
|
||||
procedure IconChanged(Sender: TObject);
|
||||
procedure Idle;
|
||||
procedure MouseIdle(const CurrentControl: TControl);
|
||||
procedure SetIcon(AValue: TIcon);
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure ControlDestroyed(AControl: TControl);
|
||||
Procedure BringToFront;
|
||||
procedure CreateForm(NewForm : TFormClass; var ref);
|
||||
procedure HandleException(Sender: TObject);
|
||||
procedure HandleMessage;
|
||||
procedure HintMouseMEssage(Control : TControl; var Message: TLMessage);
|
||||
property Icon: TIcon read FIcon write SetIcon;
|
||||
procedure Initialize;
|
||||
function MessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
|
||||
procedure Notification(AComponent : TComponent; Operation : TOperation); override;
|
||||
Procedure ProcessMessages;
|
||||
procedure Run;
|
||||
procedure ShowException(E: Exception);
|
||||
procedure Terminate;
|
||||
property Exename: String read GetExeName;
|
||||
property Handle: THandle read FHandle;
|
||||
property Terminated: Boolean read FTerminate;
|
||||
property MainForm: TForm read FMainForm;
|
||||
property OnException: TExceptionEvent read FOnException write FOnException;
|
||||
property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
|
||||
end;
|
||||
|
||||
TIDesigner = class(TObject)
|
||||
public
|
||||
|
||||
@ -262,8 +262,8 @@ begin
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TCustomForm.IsIconStored
|
||||
Returns: handle of form icon
|
||||
Method: TApplication.GetIconHandle
|
||||
Returns: handle of default form icon
|
||||
------------------------------------------------------------------------------}
|
||||
function TApplication.GetIconHandle: HICON;
|
||||
begin
|
||||
@ -273,6 +273,38 @@ begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TApplication.GetTitle
|
||||
Returns: title of application
|
||||
------------------------------------------------------------------------------}
|
||||
function TApplication.GetTitle: string;
|
||||
begin
|
||||
if FMainForm<>nil then
|
||||
Result:=FMainForm.Caption
|
||||
else
|
||||
Result:='';
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TApplication.HandleException
|
||||
Params: Sender
|
||||
Returns: Nothing
|
||||
|
||||
Handles all messages first then the Idle
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TApplication.HandleException(Sender: TObject);
|
||||
begin
|
||||
if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0);
|
||||
if ExceptObject is Exception then begin
|
||||
if not (ExceptObject is EAbort) then
|
||||
if Assigned(FOnException) then
|
||||
FOnException(Sender, Exception(ExceptObject))
|
||||
else
|
||||
ShowException(Exception(ExceptObject));
|
||||
end else
|
||||
SysUtils.ShowException(ExceptObject, ExceptAddr);
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TApplication.HandleMessage
|
||||
Params: None
|
||||
@ -310,6 +342,18 @@ procedure TApplication.wndproc(var Message : TLMessage);
|
||||
begin
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
{ TApplication ShowException }
|
||||
{------------------------------------------------------------------------------}
|
||||
procedure TApplication.ShowException(E: Exception);
|
||||
var
|
||||
Msg: string;
|
||||
begin
|
||||
Msg := E.Message;
|
||||
if (Msg <> '') and (Msg[length(Msg)] > '.') then Msg := Msg + '.';
|
||||
MessageBox(PChar(Msg), PChar(GetTitle), MB_OK + MB_ICONERROR);
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
{ TApplication Terminate }
|
||||
{ Class is terminated and the component engine is shutdown }
|
||||
@ -345,6 +389,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.15 2001/12/08 12:35:12 lazarus
|
||||
MG: added TApplication.ShowException
|
||||
|
||||
Revision 1.14 2001/11/14 17:46:58 lazarus
|
||||
Changes to make toggling between form and unit work.
|
||||
Added BringWindowToTop
|
||||
|
||||
Loading…
Reference in New Issue
Block a user