paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-14 20:39:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: added TApplication.ShowException

Browse Source 
git-svn-id: trunk@490 -
This commit is contained in:
lazarus 2001-12-08 12:35:12 +00:00
parent e4f93900e6
commit bd75d3d4c3
2 changed files with 96 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
lcl/forms.pp
View File

@ -260,51 +260,56 @@ type
property Width : Integer read GetWidth; property Width : Integer read GetWidth;
end; end;
TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object; TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
TApplication = class(TComponent) TApplication = class(TComponent)
private private
FHandle : THandle; FHandle : THandle;
FIcon: TIcon; FIcon: TIcon;
FList: TList; FList: TList;
FMainForm : TForm; FMainForm : TForm;
FMouseControl: TControl; FMouseControl: TControl;
FOnIdle: TIdleEvent; FOnException: TExceptionEvent;
FTerminate : Boolean; FOnIdle: TIdleEvent;
// MWE:Do we need this ?? FTerminate : Boolean;
// function ProcessMessage(Var Msg : TMsg) : Boolean; // MWE:Do we need this ??
procedure wndproc(var Message : TLMessage); // function ProcessMessage(Var Msg : TMsg) : Boolean;
//the following is used for Messagebox button clicks. Temporary until I figure out a better way. procedure wndproc(var Message : TLMessage);
procedure DefaultOnClick(Sender : TObject); // 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 GetExename: String;
procedure IconChanged(Sender: TObject); function GetIconHandle: HICON;
procedure Idle; function GetTitle: string;
procedure MouseIdle(const CurrentControl: TControl); procedure IconChanged(Sender: TObject);
procedure SetIcon(AValue: TIcon); procedure Idle;
procedure MouseIdle(const CurrentControl: TControl);
public procedure SetIcon(AValue: TIcon);
constructor Create(AOwner: TComponent); override; public
destructor Destroy; override; constructor Create(AOwner: TComponent); override;
procedure ControlDestroyed(AControl: TControl); destructor Destroy; override;
Procedure BringToFront; procedure ControlDestroyed(AControl: TControl);
procedure CreateForm(NewForm : TFormClass; var ref); Procedure BringToFront;
procedure HandleMessage; procedure CreateForm(NewForm : TFormClass; var ref);
procedure HintMouseMEssage(Control : TControl; var Message: TLMessage); procedure HandleException(Sender: TObject);
property Icon: TIcon read FIcon write SetIcon; procedure HandleMessage;
procedure Initialize; procedure HintMouseMEssage(Control : TControl; var Message: TLMessage);
function MessageBox(Text, Caption : PChar; Flags : Longint) : Integer; property Icon: TIcon read FIcon write SetIcon;
procedure Notification(AComponent : TComponent; Operation : TOperation); override; procedure Initialize;
Procedure ProcessMessages; function MessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
procedure Run; procedure Notification(AComponent : TComponent; Operation : TOperation); override;
procedure Terminate; Procedure ProcessMessages;
property Exename: String read GetExeName; procedure Run;
property Handle: THandle read FHandle; procedure ShowException(E: Exception);
property Terminated: Boolean read FTerminate; procedure Terminate;
property MainForm: TForm read FMainForm; property Exename: String read GetExeName;
property OnIdle: TIdleEvent read FOnIdle write FOnIdle; property Handle: THandle read FHandle;
end; 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) TIDesigner = class(TObject)
public public

51
lcl/include/application.inc
View File

@ -262,8 +262,8 @@ begin
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Method: TCustomForm.IsIconStored Method: TApplication.GetIconHandle
Returns: handle of form icon Returns: handle of default form icon
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TApplication.GetIconHandle: HICON; function TApplication.GetIconHandle: HICON;
begin begin
@ -273,6 +273,38 @@ begin
Result:=0; Result:=0;
end; 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 Method: TApplication.HandleMessage
Params: None Params: None
@ -310,6 +342,18 @@ procedure TApplication.wndproc(var Message : TLMessage);
begin begin
end; 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 } { TApplication Terminate }
{ Class is terminated and the component engine is shutdown } { Class is terminated and the component engine is shutdown }
@ -345,6 +389,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $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 Revision 1.14 2001/11/14 17:46:58 lazarus
Changes to make toggling between form and unit work. Changes to make toggling between form and unit work.
Added BringWindowToTop Added BringWindowToTop