home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / EXCPTDLG.PAS < prev    next >
Pascal/Delphi Source File  |  2001-06-24  |  10KB  |  374 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Delphi VCL Extensions (RX)                      }
  4. {                                                       }
  5. {       Copyright (c) 1997, 1998 Master-Bank            }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit ExcptDlg;
  10.  
  11. {$I RX.INC}
  12.  
  13. interface
  14.  
  15. uses
  16.   SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  17.   StdCtrls, ExtCtrls, RXCtrls;
  18.  
  19. type
  20.   TErrorEvent = procedure (Error: Exception; var Msg: string) of object;
  21.  
  22.   TRxErrorDialog = class(TForm)
  23.     BasicPanel: TPanel;
  24.     ErrorText: TLabel;
  25.     IconPanel: TPanel;
  26.     IconImage: TImage;
  27.     TopPanel: TPanel;
  28.     RightPanel: TPanel;
  29.     DetailsPanel: TPanel;
  30.     MessageText: TMemo;
  31.     ErrorAddress: TEdit;
  32.     ErrorType: TEdit;
  33.     ButtonPanel: TPanel;
  34.     DetailsBtn: TButton;
  35.     OKBtn: TButton;
  36.     AddrLabel: TRxLabel;
  37.     TypeLabel: TRxLabel;
  38.     BottomPanel: TPanel;
  39.     procedure FormCreate(Sender: TObject);
  40.     procedure FormDestroy(Sender: TObject);
  41.     procedure FormShow(Sender: TObject);
  42.     procedure DetailsBtnClick(Sender: TObject);
  43.     procedure ErrorInfo(var LogicalAddress: Pointer; var ModuleName: string);
  44.     procedure FormKeyUp(Sender: TObject; var Key: Word;
  45.       Shift: TShiftState);
  46.   private
  47.     Details: Boolean;
  48.     DetailsHeight: Integer;
  49.     ExceptObj: Exception;
  50.     FPrevOnException: TExceptionEvent;
  51.     FOnErrorMsg: TErrorEvent;
  52. {$IFDEF WIN32}
  53.     FHelpFile: string;
  54. {$ENDIF}
  55.     procedure GetErrorMsg(var Msg: string);
  56.     procedure ShowError;
  57.     procedure SetShowDetails(Value: Boolean);
  58. {$IFDEF WIN32}
  59.     procedure WMHelp(var Message: TWMHelp); message WM_HELP;
  60. {$ENDIF}
  61.   public
  62.     procedure ShowException(Sender: TObject; E: Exception);
  63.     property OnErrorMsg: TErrorEvent read FOnErrorMsg write FOnErrorMsg;
  64.   end;
  65.  
  66. const
  67.   ErrorDlgHelpCtx: THelpContext = 0;
  68.  
  69. var
  70.   RxErrorDialog: TRxErrorDialog;
  71.  
  72. procedure RxErrorIntercept;
  73.  
  74. implementation
  75.  
  76. uses
  77. {$IFDEF WIN32}
  78.   Windows, {$IFDEF RX_D3} ComObj, {$ELSE} OleAuto, {$ENDIF RX_D3}
  79. {$ELSE WIN32}
  80.   WinProcs, WinTypes, ToolHelp, Str16,
  81. {$ENDIF WIN32}
  82.   Consts, RxCConst, rxStrUtils, VCLUtils;
  83.  
  84. {$R *.DFM}
  85.  
  86. {$IFDEF RX_D3}
  87. resourcestring
  88. {$ELSE}
  89. const
  90. {$ENDIF}
  91.   SCodeError = '%s.'#13#10'Error Code: %.8x (%1:d).';
  92.   SModuleError = 'Exception in module %s.'#13#10'%s';
  93.  
  94. const
  95.   CRLF = #13#10;
  96.  
  97. procedure RxErrorIntercept;
  98. begin
  99.   if RxErrorDialog <> nil then RxErrorDialog.Free;
  100.   RxErrorDialog := TRxErrorDialog.Create(Application);
  101. end;
  102.  
  103. { TRxErrorDialog }
  104.  
  105. procedure TRxErrorDialog.ShowException(Sender: TObject; E: Exception);
  106. begin
  107.   Screen.Cursor := crDefault;
  108.   Application.NormalizeTopMosts;
  109.   try
  110.     if Assigned(FPrevOnException) then FPrevOnException(Sender, E)
  111.     else if (ExceptObj = nil) and not Application.Terminated then begin
  112.       ExceptObj := E;
  113.       try
  114.         ShowModal;
  115.       finally
  116.         ExceptObj := nil;
  117.       end;
  118.     end
  119.     else begin
  120.       if NewStyleControls then Application.ShowException(E)
  121.       else MessageDlg(E.Message + '.', mtError, [mbOk], 0);
  122.     end;
  123.   except
  124.     { ignore any exceptions }
  125.   end;
  126.   Application.RestoreTopMosts;
  127. end;
  128.  
  129. {$IFDEF WIN32}
  130.  
  131. function ConvertAddr(Address: Pointer): Pointer; assembler;
  132. asm
  133.         TEST    EAX,EAX
  134.         JE      @@1
  135.         SUB     EAX, $1000
  136. @@1:
  137. end;
  138.  
  139. procedure TRxErrorDialog.ErrorInfo(var LogicalAddress: Pointer;
  140.   var ModuleName: string);
  141. var
  142.   Info: TMemoryBasicInformation;
  143.   Temp, ModName: array[0..MAX_PATH] of Char;
  144. begin
  145.   VirtualQuery(ExceptAddr, Info, SizeOf(Info));
  146.   if (Info.State <> MEM_COMMIT) or
  147.     (GetModuleFilename(THandle(Info.AllocationBase), Temp,
  148.     SizeOf(Temp)) = 0) then
  149.   begin
  150.     GetModuleFileName(HInstance, Temp, SizeOf(Temp));
  151.     LogicalAddress := ConvertAddr(LogicalAddress);
  152.   end
  153.   else Integer(LogicalAddress) := Integer(LogicalAddress) -
  154.     Integer(Info.AllocationBase);
  155. {$IFDEF RX_D3}
  156.   StrLCopy(ModName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModName) - 1);
  157. {$ELSE}
  158.   StrLCopy(ModName, StrRScan(Temp, '\') + 1, SizeOf(ModName) - 1);
  159. {$ENDIF}
  160.   ModuleName := StrPas(ModName);
  161. end;
  162.  
  163. {$ELSE}
  164.  
  165. function ConvertAddr(Address: Pointer): Pointer; assembler;
  166. asm
  167.         MOV     AX,Address.Word[0]
  168.         MOV     DX,Address.Word[2]
  169.         MOV     CX,DX
  170.         OR      CX,AX
  171.         JE      @@1
  172.         CMP     DX,0FFFFH
  173.         JE      @@1
  174.         MOV     ES,DX
  175.         MOV     DX,ES:Word[0]
  176. @@1:
  177. end;
  178.  
  179. procedure TRxErrorDialog.ErrorInfo(var LogicalAddress: Pointer;
  180.   var ModuleName: string);
  181. var
  182.   GlobalEntry: TGlobalEntry;
  183.   hMod: THandle;
  184.   ModName: array[0..15] of Char;
  185.   Buffer: array[0..255] of Char;
  186. begin
  187.   GlobalEntry.dwSize := SizeOf(GlobalEntry);
  188.   if GlobalEntryHandle(@GlobalEntry, THandle(PtrRec(LogicalAddress).Seg)) then
  189.     with GlobalEntry do begin
  190.       hMod := hOwner;
  191.       if wType in [GT_CODE, GT_DATA, GT_DGROUP] then
  192.         PtrRec(LogicalAddress).Seg := wData;
  193.     end
  194.     else LogicalAddress := ConvertAddr(LogicalAddress);
  195.   GetModuleFileName(hMod, Buffer, SizeOf(Buffer));
  196.   StrLCopy(ModName, StrRScan(Buffer, '\') + 1, SizeOf(ModName) - 1);
  197.   ModuleName := StrPas(ModName);
  198. end;
  199.  
  200. {$ENDIF}
  201.  
  202. procedure TRxErrorDialog.ShowError;
  203. var
  204.   S, ModuleName: string;
  205.   P: Pointer;
  206. begin
  207.   P := ExceptAddr;
  208.   ModuleName := '';
  209.   ErrorInfo(P, ModuleName);
  210.   AddrLabel.Enabled := (P <> nil);
  211.   ErrorAddress.Text := Format('%p', [ExceptAddr]);
  212.   ErrorType.Text := ExceptObj.ClassName;
  213.   TypeLabel.Enabled := ErrorType.Text <> '';
  214.   S := Trim(ExceptObj.Message);
  215.   if Pos(CRLF, S) = 0 then
  216.     S := ReplaceStr(S, #10, CRLF);
  217.   if ExceptObj is EInOutError then
  218.     S := Format(SCodeError, [S, EInOutError(ExceptObj).ErrorCode])
  219. {$IFDEF WIN32}
  220.   else if ExceptObj is EOleException then begin
  221.     with EOleException(ExceptObj) do
  222.       if (Source <> '') and (AnsiCompareText(S, Trim(Source)) <> 0) then
  223.         S := S + CRLF + Trim(Source);
  224.     S := Format(SCodeError, [S, EOleException(ExceptObj).ErrorCode])
  225.   end
  226.   else if ExceptObj is EOleSysError then
  227.     S := Format(SCodeError, [S, EOleSysError(ExceptObj).ErrorCode])
  228.   else if ExceptObj is EExternalException then
  229.     S := Format(SCodeError, [S,
  230.       EExternalException(ExceptObj).ExceptionRecord^.ExceptionCode])
  231. {$ENDIF}
  232. {$IFDEF RX_D3}
  233.   else if ExceptObj is EWin32Error then
  234.     S := Format(SCodeError, [S, EWin32Error(ExceptObj).ErrorCode])
  235. {$ENDIF}
  236.   else S := S + '.';
  237.   MessageText.Text := Format(SModuleError, [ModuleName, S]);
  238. end;
  239.  
  240. procedure TRxErrorDialog.SetShowDetails(Value: Boolean);
  241. begin
  242.   DisableAlign;
  243.   try
  244.     if Value then begin
  245.       DetailsPanel.Height := DetailsHeight;
  246.       ClientHeight := DetailsPanel.Height + BasicPanel.Height;
  247.       DetailsBtn.Caption := '<< &' + LoadStr(SDetails);
  248.       ShowError;
  249.     end
  250.     else begin
  251.       ClientHeight := BasicPanel.Height;
  252.       DetailsPanel.Height := 0;
  253.       DetailsBtn.Caption := '&' + LoadStr(SDetails) + ' >>';
  254.     end;
  255.     DetailsPanel.Enabled := Value;
  256.     Details := Value;
  257.   finally
  258.     EnableAlign;
  259.   end;
  260. end;
  261.  
  262. procedure TRxErrorDialog.GetErrorMsg(var Msg: string);
  263. var
  264.   I: Integer;
  265. begin
  266.   I := Pos(CRLF, Msg);
  267.   if I > 0 then System.Delete(Msg, I, MaxInt);
  268.   if Assigned(FOnErrorMsg) then
  269.     try
  270.       FOnErrorMsg(ExceptObj, Msg);
  271.     except
  272.     end;
  273. end;
  274.  
  275. {$IFDEF WIN32}
  276. procedure TRxErrorDialog.WMHelp(var Message: TWMHelp);
  277. var
  278.   AppHelpFile: string;
  279. begin
  280.   AppHelpFile := Application.HelpFile;
  281.   try
  282.     if FHelpFile <> '' then
  283.       Application.HelpFile := FHelpFile;
  284.     inherited;
  285.   finally
  286.     Application.HelpFile := AppHelpFile;
  287.   end;
  288. end;
  289. {$ENDIF}
  290.  
  291. procedure TRxErrorDialog.FormCreate(Sender: TObject);
  292. begin
  293. {$IFDEF WIN32}
  294.   BorderIcons := [biSystemMenu, biHelp];
  295. {$ELSE}
  296.   BorderIcons := [];
  297. {$ENDIF}
  298.   DetailsHeight := DetailsPanel.Height;
  299.   Icon.Handle := LoadIcon(0, IDI_HAND);
  300.   IconImage.Picture.Icon := Icon;
  301.   { Load string resources }
  302.   Caption := ResStr(SMsgDlgError);
  303.   OKBtn.Caption := ResStr(SOKButton);
  304.   { Set exception handler }
  305.   FPrevOnException := Application.OnException;
  306.   Application.OnException := ShowException;
  307. end;
  308.  
  309. procedure TRxErrorDialog.FormDestroy(Sender: TObject);
  310. begin
  311.   Application.OnException := FPrevOnException;
  312. end;
  313.  
  314. procedure TRxErrorDialog.FormShow(Sender: TObject);
  315. var
  316.   S: string;
  317. {$IFDEF WIN32}
  318.   ExStyle: Longint;
  319. {$ENDIF}
  320. begin
  321.   if ExceptObj.HelpContext <> 0 then
  322.     HelpContext := ExceptObj.HelpContext
  323.   else HelpContext := ErrorDlgHelpCtx;
  324. {$IFDEF WIN32}
  325.   if ExceptObj is EOleException then
  326.     FHelpFile := EOleException(ExceptObj).HelpFile
  327.   else FHelpFile := '';
  328.   ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
  329.   if (HelpContext <> 0) then
  330.     ExStyle := ExStyle or WS_EX_CONTEXTHELP
  331.   else
  332.     ExStyle := ExStyle and not WS_EX_CONTEXTHELP;
  333.   SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);
  334. {$ENDIF}
  335.   S := Trim(ExceptObj.Message) + '.';
  336.   GetErrorMsg(S);
  337.   ErrorText.Caption := S;
  338.   SetShowDetails(False);
  339.   DetailsBtn.Enabled := True;
  340. end;
  341.  
  342. procedure TRxErrorDialog.DetailsBtnClick(Sender: TObject);
  343. begin
  344.   SetShowDetails(not Details);
  345. end;
  346.  
  347. procedure TRxErrorDialog.FormKeyUp(Sender: TObject; var Key: Word;
  348.   Shift: TShiftState);
  349. {$IFDEF WIN32}
  350. var
  351.   Info: THelpInfo;
  352. {$ENDIF}
  353. begin
  354.   if (Key = VK_F1) and (HelpContext <> 0) then begin
  355. {$IFDEF WIN32}
  356.     with Info do begin
  357.       cbSize := SizeOf(THelpInfo);
  358.       iContextType := HELPINFO_WINDOW;
  359.       iCtrlId := 0;
  360.       hItemHandle := Handle;
  361.       dwContextId := HelpContext;
  362.       GetCursorPos(MousePos);
  363.     end;
  364.     Perform(WM_HELP, 0, Longint(@Info));
  365. {$ELSE}
  366.     Application.HelpContext(HelpContext);
  367. {$ENDIF}
  368.   end;
  369. end;
  370.  
  371. initialization
  372.   RxErrorDialog := nil;
  373. end.
  374.