home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / DBEXCEPT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-04  |  3.9 KB  |  151 lines
  1. unit Dbexcept;
  2.  
  3. interface
  4.  
  5. uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Buttons,
  6.   StdCtrls, ExtCtrls, Db, DBTables;
  7.  
  8. type
  9.   TDbEngineErrorDlg = class(TForm)
  10.     BasicPanel: TPanel;
  11.     DetailsPanel: TPanel;
  12.     BDELabel: TLabel;
  13.     NativeLabel: TLabel;
  14.     DbMessageText: TMemo;
  15.     DbResult: TEdit;
  16.     DbCatSub: TEdit;
  17.     NativeResult: TEdit;
  18.     BackBtn: TButton;
  19.     NextBtn: TButton;
  20.     ButtonPanel: TPanel;
  21.     DetailsBtn: TButton;
  22.     OKBtn: TButton;
  23.     IconPanel: TPanel;
  24.     IconImage: TImage;
  25.     TopPanel: TPanel;
  26.     ErrorText: TLabel;
  27.     RightPanel: TPanel;
  28.     procedure FormShow(Sender: TObject);
  29.     procedure BackClick(Sender: TObject);
  30.     procedure NextClick(Sender: TObject);
  31.     procedure FormCreate(Sender: TObject);
  32.     procedure DetailsBtnClick(Sender: TObject);
  33.     procedure FormDestroy(Sender: TObject);
  34.   private
  35.     FPrevOnException: TExceptionEvent;
  36.     FDbException: EDbEngineError;
  37.     FDetailsHeight, CurItem: Integer;
  38.     FDetails: string;
  39.     procedure HandleException(Sender: TObject; E: Exception);
  40.     procedure SwitchDetails;
  41.     procedure ShowError;
  42.   public
  43.     procedure HookExceptions;
  44.     function ShowException(Error: EDbEngineError): TModalResult;
  45.     property DbException: EDbEngineError read FDbException write FDbException;
  46.   end;
  47.  
  48. var
  49.   DbEngineErrorDlg: TDbEngineErrorDlg;
  50.  
  51. implementation
  52.  
  53. {$R *.DFM}
  54.  
  55. procedure TDbEngineErrorDlg.HandleException(Sender: TObject; E: Exception);
  56. begin
  57.   if (E is EDbEngineError) and (DbException = nil) and
  58.     not Application.Terminated then ShowException(EDbEngineError(E))
  59.   else if Assigned(FPrevOnException) then FPrevOnException(Sender, E)
  60.   else Application.ShowException(E);
  61. end;
  62.  
  63. procedure TDbEngineErrorDlg.SwitchDetails;
  64. const
  65.   DetailsOn: array [Boolean] of string = ('%s >>', '<< %s');
  66. var
  67.   DEnabling: Boolean;
  68. begin
  69.   DEnabling := not DetailsPanel.Visible;
  70.   if DEnabling then ClientHeight := FDetailsHeight
  71.   else ClientHeight := DetailsPanel.Top;
  72.   DetailsPanel.Visible := DEnabling;
  73.   ButtonPanel.Top := 0;
  74.   DetailsBtn.Caption := Format(DetailsOn[DEnabling], [FDetails]);
  75. end;
  76.  
  77. procedure TDbEngineErrorDlg.ShowError;
  78. var
  79.   BDEError: TDbError;
  80. begin
  81.   BackBtn.Enabled := CurItem > 0;
  82.   NextBtn.Enabled := CurItem < DbException.ErrorCount - 1;
  83.   BDEError := DbException.Errors[CurItem];
  84.   DbMessageText.Text := BDEError.Message;
  85.   BDELabel.Enabled := True;
  86.   DbResult.Text := IntToStr(BDEError.ErrorCode);
  87.   DbCatSub.Text := Format('[$%2x] [$%2x]', [BDEError.Category, BDEError.SubCode]);
  88.   NativeLabel.Enabled := BDEError.NativeError <> 0;
  89.   if NativeLabel.Enabled then NativeResult.Text := IntToStr(BDEError.NativeError)
  90.   else NativeResult.Clear
  91. end;
  92.  
  93. procedure TDbEngineErrorDlg.FormCreate(Sender: TObject);
  94. begin
  95.   FDetailsHeight := ClientHeight;
  96.   FDetails := DetailsBtn.Caption;
  97.   SwitchDetails;
  98. end;
  99.  
  100. procedure TDbEngineErrorDlg.FormDestroy(Sender: TObject);
  101. begin
  102.   if Assigned(FPrevOnException) then Application.OnException := FPrevOnException;
  103. end;
  104.  
  105. procedure TDbEngineErrorDlg.FormShow(Sender: TObject);
  106. begin
  107.   ErrorText.Caption := DbException.Message;
  108.   if DetailsPanel.Visible then
  109.   begin
  110.     CurItem := 0;
  111.     ShowError;
  112.   end;
  113. end;
  114.  
  115. procedure TDbEngineErrorDlg.BackClick(Sender: TObject);
  116. begin
  117.   Dec(CurItem);
  118.   ShowError;
  119. end;
  120.  
  121. procedure TDbEngineErrorDlg.NextClick(Sender: TObject);
  122. begin
  123.   Inc(CurItem);
  124.   ShowError;
  125. end;
  126.  
  127. procedure TDbEngineErrorDlg.DetailsBtnClick(Sender: TObject);
  128. begin
  129.   SwitchDetails;
  130.   if DetailsPanel.Visible then
  131.   begin
  132.     CurItem := 0;
  133.     ShowError;
  134.   end;
  135. end;
  136.  
  137. procedure TDbEngineErrorDlg.HookExceptions;
  138. begin
  139.   FPrevOnException := Application.OnException;
  140.   Application.OnException := HandleException;
  141. end;
  142.  
  143. function TDbEngineErrorDlg.ShowException(Error: EDbEngineError): TModalResult;
  144. begin
  145.   DbException := Error;
  146.   Result := ShowModal;
  147.   DbException := nil;
  148. end;
  149.  
  150. end.
  151.