
{                                                                              }
{ IBD_Error                                                                    }
{                                                                              }

{***************************************************************}
{                                                               }
{          IB Objects Components and Resources Library          }
{                                                               }
{          Copyright (C) 1996-2007 Jason Wharton                }
{          and Computer Programming Solutions, Mesa, AZ         }
{                                                               }
{  This source code unit is released under the terms of the     }
{  CPS Trustware License.                                       }
{  It may be distributed or deployed as source code or in       }
{  compiled form only in compliance with the terms and          }
{  conditions of the CPS Trustware License which may be         )
{  examined at http://www.ibobjects.com/ibo_trustware.html      )
{                                                               }
{***************************************************************}

{******************************************************************************}
{  CONTRIBUTED MODIFICATIONS                                                   }
{  Additions or modifications listed below using format:                       }
{                                                                              }
{  Joe Citizen <joe@joecitizen.com>                                            }
{  mm/dd/yyyy                                                                  }
{     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx                 }
{     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx                 }
{     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx                 }
{            Copyright (C) 2001 Joe Citizen                                    }
{                                                                              }
{------------------------------------------------------------------------------}
{  Place your credits and information in the top of the section                }
{  below with any other descriptions or explanations desired.                  }
{------------------------------------------------------------------------------}
{                                                                              }
{  Hans Hoogstraat <HHoogstraat@Shaw.ca>                                       }
{  07/12/2007                                                                  }
{    Fixed an infinite loop in the handling of exceptions.                     }
{                                                                              }
{******************************************************************************}

{$INCLUDE IB_Directives.inc}

unit
  IBD_Error;

interface

uses
  Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls, 
  Buttons, ExtCtrls, ComCtrls, Messages;

type
  TdlgError = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    OKBtn: TButton;
    pcError: TPageControl;
    tsErrorMsg: TTabSheet;
    meError: TMemo;
    tsSQLMsg: TTabSheet;
    meSQLMsg: TMemo;
    tsSQL: TTabSheet;
    meSQL: TMemo;
    lbCursorPos: TLabel;
    Button1: TButton;
    procedure meSQLEnter( Sender: TObject );
    procedure meSQLKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure meSQLMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure meSQLMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure meSQLKeyPress(Sender: TObject; var Key: Char);
    procedure FormShow( Sender: TObject );
    procedure pcErrorChange( Sender: TObject );
    procedure FormCreate( Sender: TObject );
    procedure FormActivate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    Scrolled: boolean;
    { Private declarations }
  public
    procedure UpdateCursorPos;
    procedure InitializeDialog( const ErrMsg, SQLMsg, SQLTxt: string );
    { Public declarations }
  end;

var
  dlgError: TdlgError;

implementation

{$R *.DFM}

uses
  IBF_Status;

procedure TdlgError.UpdateCursorPos;
var
  CaretPos: TPoint;
begin
  with CaretPos do
  begin
    X := LongRec( SendMessage( meSQL.Handle, EM_GETSEL, 0, 0 )).Hi;
    Y := SendMessage( meSQL.Handle, EM_LINEFROMCHAR, X, 0 );
    X := X - SendMessage( meSQL.Handle, EM_LINEINDEX, -1, 0 );
    lbCursorPos.Caption := IntToStr( Y + 1 ) + ': ' + IntToStr( X );
  end;
end;

procedure TdlgError.InitializeDialog( const ErrMsg, SQLMsg, SQLTxt: string );
var
  ii: integer;
  tmpStr: string;
  tmpPos: integer;
  tmpLine: integer;
  tmpChar: integer;
begin
  meError.Lines.Text := Trim( AdjustLineBreaks( ErrMsg ));
  meSQLMsg.Lines.Text := Trim( AdjustLineBreaks( SQLMsg ));
  meSQL.Lines.Text := Trim( AdjustLineBreaks( SQLTxt ));
  if meSQLMsg.Lines.Count = 0 then
    tsSQLMsg.TabVisible := false;
  if meSQL.Lines.Count = 0 then
    tsSQL.TabVisible := false;
  pcError.ActivePage := tsErrorMsg;
  tmpLine := 0;
  tmpChar := 0;
  ii := 0;
  while ( ii < meError.Lines.Count ) and
        (( tmpLine = 0 ) or ( tmpChar = 0 )) do
  begin
    try
      tmpStr := meError.Lines[ ii ];
      tmpPos := Pos( 'line', LowerCase( tmpStr ));
      if tmpPos > 0 then
      begin
        tmpStr := Copy( tmpStr, tmpPos + 4, MaxInt );
        tmpPos := Pos( ',', tmpStr );
        if tmpPos > 0 then
        begin
          tmpLine := StrToIntDef(Trim(Copy(tmpStr, 1, tmpPos - 1)), -1);
          Delete( tmpStr, 1, tmpPos );
          tmpPos := Pos( 'col', LowerCase( tmpStr ));
          if tmpPos > 0 then
          begin
            Delete( tmpStr, 1, tmpPos + 2 );
            tmpPos := Pos( ' ', tmpStr );
            if tmpPos > 0 then
            begin
              Delete( tmpStr, 1, tmpPos );
              tmpStr := Trim( tmpStr );
              tmpChar := StrToIntDef(Trim(tmpStr), -1);
              if tmpChar < 0 then
              begin
                meError.Lines.Add('');
                meError.Lines.Add('Possibly an older version of FBClient.dll in Path');
              end;
            end;
          end;
        end;
      end;
    except
    // Yummy good.
    end;
    Inc(ii);
  end;
  if ( tmpLine > 0 ) and ( tmpChar > 0 ) then
  begin
    tmpLine := SendMessage( meSQL.Handle, EM_LINEINDEX, tmpLine - 1, 0 );
    if tmpLine >= 0 then
    begin
      meSQL.SelStart := tmpLine + tmpChar;
      SendMessage( meSQL.Handle, EM_SCROLLCARET, 0, 0 );
    end;
  end;
end;

procedure TdlgError.meSQLEnter( Sender: TObject );
begin
  UpdateCursorPos;
end;

procedure TdlgError.meSQLKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  UpdateCursorPos;
end;

procedure TdlgError.meSQLMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  UpdateCursorPos;
end;

procedure TdlgError.meSQLMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  UpdateCursorPos;
end;

procedure TdlgError.meSQLKeyPress(Sender: TObject; var Key: Char);
begin
  UpdateCursorPos;
end;

procedure TdlgError.FormShow( Sender: TObject );
begin
  UpdateCursorPos;
end;

procedure TdlgError.pcErrorChange( Sender: TObject );
begin
  if not Scrolled then
  begin
    if pcError.ActivePage = tsSQL then
    begin
      meSQL.SetFocus;
      SendMessage( meSQL.Handle, EM_SCROLLCARET, 0, 0 );
      SendMessage( meSQL.Handle, EM_SCROLL, SB_LINEDOWN, 0 );
      SendMessage( meSQL.Handle, EM_SCROLL, SB_LINEDOWN, 0 );
    end;
    Scrolled := true;
  end;
end;

procedure TdlgError.FormCreate( Sender: TObject );
begin
  Scrolled := false;
end;

procedure TdlgError.FormActivate(Sender: TObject);
begin
{$IFDEF IBO_VCL30_OR_GREATER}
  HelpFile := 'IBO.HLP';
{$ENDIF}  
end;

procedure TdlgError.Button1Click(Sender: TObject);
begin
  if not Assigned( frmStatus ) then
    Application.CreateForm( TfrmStatus, frmStatus );
  frmStatus.ShowModal;
end;

end.

