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