home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / DBEXCPT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  6.8 KB  |  244 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {       TRxBdeErrorDlg based on sample form             }
  10. {       DELPHI\DEMOS\DB\TOOLS\DBEXCEPT.PAS              }
  11. {*******************************************************}
  12.  
  13. unit DbExcpt;
  14.  
  15. {$I RX.INC}
  16.  
  17. interface
  18.  
  19. uses
  20.   SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  21.   StdCtrls, ExtCtrls, DB, {$IFDEF RX_D3} DBTables, {$ENDIF} RXCtrls;
  22.  
  23. type
  24.   TDBErrorEvent = procedure (Error: TDBError; var Msg: string) of object;
  25.  
  26.   TRxBdeErrorDlg = class(TForm)
  27.     BasicPanel: TPanel;
  28.     ErrorText: TLabel;
  29.     IconPanel: TPanel;
  30.     IconImage: TImage;
  31.     TopPanel: TPanel;
  32.     RightPanel: TPanel;
  33.     DetailsPanel: TPanel;
  34.     DbMessageText: TMemo;
  35.     DbResult: TEdit;
  36.     DbCatSub: TEdit;
  37.     NativeResult: TEdit;
  38.     Back: TButton;
  39.     Next: TButton;
  40.     ButtonPanel: TPanel;
  41.     DetailsBtn: TButton;
  42.     OKBtn: TButton;
  43.     BDELabel: TRxLabel;
  44.     NativeLabel: TRxLabel;
  45.     BottomPanel: TPanel;
  46.     procedure FormCreate(Sender: TObject);
  47.     procedure FormDestroy(Sender: TObject);
  48.     procedure FormShow(Sender: TObject);
  49.     procedure DetailsBtnClick(Sender: TObject);
  50.     procedure BackClick(Sender: TObject);
  51.     procedure NextClick(Sender: TObject);
  52.   private
  53.     CurItem: Integer;
  54.     Details: Boolean;
  55.     DetailsHeight: Integer;
  56.     DbException: EDbEngineError;
  57.     FPrevOnException: TExceptionEvent;
  58.     FOnErrorMsg: TDBErrorEvent;
  59.     procedure GetErrorMsg(Error: TDBError; var Msg: string);
  60.     procedure ShowError;
  61.     procedure SetShowDetails(Value: Boolean);
  62.   public
  63.     procedure ShowException(Sender: TObject; E: Exception);
  64.     property OnErrorMsg: TDBErrorEvent read FOnErrorMsg write FOnErrorMsg;
  65.   end;
  66.  
  67. const
  68.   DbErrorHelpCtx: THelpContext = 0;
  69.  
  70. var
  71.   DbEngineErrorDlg: TRxBdeErrorDlg;
  72.  
  73. procedure DbErrorIntercept;
  74.  
  75. implementation
  76.  
  77. uses {$IFDEF WIN32} Windows, BDE, {$ELSE} WinProcs, WinTypes, DbiErrs,
  78.   Str16, {$ENDIF} Consts, RxDConst, RxCConst, VCLUtils;
  79.  
  80. {$R *.DFM}
  81.  
  82. procedure DbErrorIntercept;
  83. begin
  84.   if DbEngineErrorDlg <> nil then DbEngineErrorDlg.Free;
  85.   DbEngineErrorDlg := TRxBdeErrorDlg.Create(Application);
  86. end;
  87.  
  88. { TRxBdeErrorDlg }
  89.  
  90. procedure TRxBdeErrorDlg.ShowException(Sender: TObject; E: Exception);
  91. begin
  92.   Screen.Cursor := crDefault;
  93.   Application.NormalizeTopMosts;
  94.   try
  95.     if (E is EDbEngineError) and (DbException = nil)
  96.       and not Application.Terminated then
  97.     begin
  98.       DbException := EDbEngineError(E);
  99.       try
  100.         ShowModal;
  101.       finally
  102.         DbException := nil;
  103.       end;
  104.     end
  105.     else begin
  106.       if Assigned(FPrevOnException) then FPrevOnException(Sender, E)
  107.       else if NewStyleControls then Application.ShowException(E)
  108.       else MessageDlg(E.Message + '.', mtError, [mbOk], 0);
  109.     end;
  110.   except
  111.     { ignore any exceptions }
  112.   end;
  113.   Application.RestoreTopMosts;
  114. end;
  115.  
  116. procedure TRxBdeErrorDlg.ShowError;
  117. var
  118.   BDEError: TDbError;
  119.   S: string;
  120.   I: Integer;
  121. begin
  122.   Back.Enabled := CurItem > 0;
  123.   Next.Enabled := CurItem < DbException.ErrorCount - 1;
  124.   BDEError := DbException.Errors[CurItem];
  125.   { Fill BDE error information }
  126.   BDELabel.Enabled := True;
  127.   DbResult.Text := IntToStr(BDEError.ErrorCode);
  128.   DbCatSub.Text := Format('[$%s] [$%s]', [IntToHex(BDEError.Category, 2),
  129.     IntToHex(BDEError.SubCode,  2)]);
  130.   { Fill native error information }
  131.   NativeLabel.Enabled := BDEError.NativeError <> 0;
  132.   if NativeLabel.Enabled then
  133.     NativeResult.Text := IntToStr(BDEError.NativeError)
  134.   else NativeResult.Clear;
  135.   { The message text is common to both BDE and native errors }
  136.   S := Trim(BDEError.Message);
  137.   for I := 1 to Length(S) do
  138.     if S[I] < ' ' then S[I] := ' ';
  139.   {GetErrorMsg(BDEError, S);}
  140.   DbMessageText.Text := Trim(S);
  141. end;
  142.  
  143. procedure TRxBdeErrorDlg.SetShowDetails(Value: Boolean);
  144. begin
  145.   DisableAlign;
  146.   try
  147.     if Value then begin
  148.       DetailsPanel.Height := DetailsHeight;
  149.       ClientHeight := DetailsPanel.Height + BasicPanel.Height;
  150.       DetailsBtn.Caption := '<< &' + LoadStr(SDetails);
  151.       CurItem := 0;
  152.       ShowError;
  153.     end
  154.     else begin
  155.       ClientHeight := BasicPanel.Height;
  156.       DetailsPanel.Height := 0;
  157.       DetailsBtn.Caption := '&' + LoadStr(SDetails) + ' >>';
  158.     end;
  159.     DetailsPanel.Enabled := Value;
  160.     Details := Value;
  161.   finally
  162.     EnableAlign;
  163.   end;
  164. end;
  165.  
  166. procedure TRxBdeErrorDlg.GetErrorMsg(Error: TDBError; var Msg: string);
  167. begin
  168.   if Assigned(FOnErrorMsg) then
  169.   try
  170.     FOnErrorMsg(Error, Msg);
  171.   except
  172.   end;
  173. end;
  174.  
  175. procedure TRxBdeErrorDlg.FormCreate(Sender: TObject);
  176. begin
  177. {$IFNDEF WIN32}
  178.   BorderIcons := [];
  179. {$ENDIF}
  180.   DetailsHeight := DetailsPanel.Height;
  181.   Icon.Handle := LoadIcon(0, IDI_EXCLAMATION);
  182.   IconImage.Picture.Icon := Icon;
  183.   { Load string resources }
  184.   Caption := LoadStr(SDBExceptCaption);
  185.   BDELabel.Caption := LoadStr(SBDEErrorLabel);
  186.   NativeLabel.Caption := LoadStr(SServerErrorLabel);
  187.   Next.Caption := LoadStr(SNextButton) + ' >';
  188.   Back.Caption := '< ' + LoadStr(SPrevButton);
  189.   OKBtn.Caption := ResStr(SOKButton);
  190.   { Set exception handler }
  191.   FPrevOnException := Application.OnException;
  192.   Application.OnException := ShowException;
  193. end;
  194.  
  195. procedure TRxBdeErrorDlg.FormDestroy(Sender: TObject);
  196. begin
  197.   Application.OnException := FPrevOnException;
  198. end;
  199.  
  200. procedure TRxBdeErrorDlg.FormShow(Sender: TObject);
  201. var
  202.   S: string;
  203.   ErrNo: Integer;
  204. begin
  205.   if DbException.HelpContext <> 0 then
  206.     HelpContext := DbException.HelpContext
  207.   else HelpContext := DbErrorHelpCtx;
  208.   CurItem := 0;
  209.   if (DbException.ErrorCount > 1) and
  210.     (DbException.Errors[1].NativeError <> 0) and
  211.     ((DbException.Errors[0].ErrorCode = DBIERR_UNKNOWNSQL) or
  212.     { General SQL error }
  213.     (DbException.Errors[0].ErrorCode = DBIERR_INVALIDUSRPASS)) then
  214.     { Unknown username or password }
  215.     ErrNo := 1
  216.   else ErrNo := 0;
  217.   S := Trim(DbException.Errors[ErrNo].Message);
  218.   GetErrorMsg(DbException.Errors[ErrNo], S);
  219.   ErrorText.Caption := S;
  220.   SetShowDetails(False);
  221.   DetailsBtn.Enabled := DbException.ErrorCount > 0;
  222. end;
  223.  
  224. procedure TRxBdeErrorDlg.DetailsBtnClick(Sender: TObject);
  225. begin
  226.   SetShowDetails(not Details);
  227. end;
  228.  
  229. procedure TRxBdeErrorDlg.BackClick(Sender: TObject);
  230. begin
  231.   Dec(CurItem);
  232.   ShowError;
  233. end;
  234.  
  235. procedure TRxBdeErrorDlg.NextClick(Sender: TObject);
  236. begin
  237.   Inc(CurItem);
  238.   ShowError;
  239. end;
  240.  
  241. initialization
  242.   DbEngineErrorDlg := nil;
  243. end.
  244.