Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/QDB/ARCHIVE.ZIP/arc_main.pas

Pascal/Delphi Source File | 1998-06-28 | 9KB | 288 lines

// This will not compile under Delphi 1
{*****************************************************************************}
{                                                                             }
{                             Archive Demo                                    }
{                                                                             }
{                     illustrating the use of the                             }
{                                                                             }
{               QDB v2.10 Visual Components for Delphi 1, 2, & 3              }
{                                                                             }
{       Copyright (c) 1995, 1996, 1997, 1998 Robert R. Marsh, S.J.            }
{             & the British Province of the Society of Jesus                  }
{                                                                             }
{                                                                             }
{       You may use this demonstration application and modify it in           }
{       whatever way you choose. You may not, however, sell it for            }
{       profit unless the changes you have made are substantial (i.e.,        }
{       more than 50% new code), in which case I'd appreciate                 }
{       receiving a copy of your new work.                                    }
{                                                                             }
{       If you like QDBDemo3 and find yourself using it please                }
{       consider making a donation to your favorite charity.                  }
{                                                                             }
{    Users of Archive must accept the following disclaimer of warranty:       }
{                                                                             }
{       Archive is supplied as is. The author disclaims all warranties,       }
{       expressed or implied, including, without limitation, the              }
{       warranties of merchantability and of fitness for any purpose.         }
{       The author assumes no liability for damages, direct or                }
{       consequential, which may result from the use of Archive.              }
{                                                                             }
{*****************************************************************************}

unit arc_main;

interface

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

type
  TArc_Form = class(TForm)
    MainMenu: TMainMenu;
    FileNewItem: TMenuItem;
    FileOpenItem: TMenuItem;
    FileSaveItem: TMenuItem;
    FileExitItem: TMenuItem;
    EditCopyItem: TMenuItem;
    OpenDialog: TOpenDialog;
    SpeedBar: TPanel;
    SpeedButton1: TSpeedButton; { &New }
    SpeedButton2: TSpeedButton; { &Open... }
    SpeedButton3: TSpeedButton; { &Save }
    SpeedButton4: TSpeedButton; { E&xit }
    SpeedButton5: TSpeedButton;
    FindDialog: TFindDialog;
    QDB: TQDB;
    Contents: TRichEdit;
    Panel1: TPanel;
    QDBNavigator: TQDBNavigator;
    Add: TButton;
    Find: TButton;
    PlainText: TCheckBox;
    FileSep1: TMenuItem;
    SpeedButton7: TSpeedButton;
    FileCloseItem: TMenuItem; { &Contents }
    procedure FileNew(Sender: TObject);
    procedure FileOpen(Sender: TObject);
    procedure FileSave(Sender: TObject);
    procedure FileClose(Sender: TObject);
    procedure FileExit(Sender: TObject);
    procedure EditCopy(Sender: TObject);
    procedure MyEnable;
    procedure MyDisable;
    procedure AddClick(Sender: TObject);
    procedure PlainTextClick(Sender: TObject);
    procedure FindClick(Sender: TObject);
    procedure QDBNavigate(Sender: TObject);
    procedure FindDialogFind(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure QDBWarnNoData(Sender: TObject);
  end;

var
  Arc_Form: TArc_Form;

implementation


{$R *.DFM}

procedure TArc_Form.MyEnable;
begin
  Add.enabled := true;
  PlainText.enabled := true;
  Find.enabled := true;
  QDBNavigator.enabled := true;
end;

procedure TArc_Form.MyDisable;
begin
  Add.enabled := false;
  PlainText.enabled := false;
  Find.enabled := false;
  QDBNavigator.enabled := false;
end;

procedure TArc_Form.FileNew(Sender: TObject);
begin
  OpenDialog.Options := [ofOverwritePrompt];
  OpenDialog.DefaultExt := '.QDB';
  OpenDialog.Title := 'Create a new knowledge-base';
  if OpenDialog.Execute then
  begin
    QDB.FileName := '';
    Contents.Clear;
    QDB.FileName := OpenDialog.Files[0];
    QDB.FirstItem;
    MyEnable;
  end;
end;

procedure TArc_Form.FileOpen(Sender: TObject);
begin
  OpenDialog.Options := [ofExtensionDifferent, ofPathMustExist, ofFileMustExist];
  OpenDialog.Filter := 'QDB Files|*.QDB|All Files|*.*';
  OpenDialog.DefaultExt := '.QDB';
  OpenDialog.Title := 'Open an existing database';
  if OpenDialog.Execute then
  begin
    Screen.Cursor := crHourGlass;
    QDB.FileName := '';
    Contents.Clear;
    QDB.FileName := OpenDialog.Files[0];
    QDB.FirstItem;
    MyEnable;
    Screen.Cursor := crDefault;
  end;
end;

procedure TArc_Form.FileSave(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  QDB.Save;
  Screen.Cursor := crDefault;
end;

procedure TArc_Form.FileClose(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  QDB.FileName := '';
  Contents.Clear;
  MyDisable;
  Screen.Cursor := crDefault;
end;

procedure TArc_Form.FileExit(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  QDB.FileName := '';
  Close;
end;

procedure TArc_Form.EditCopy(Sender: TObject);
begin
  if Contents.SelLength = 0 then Contents.SelectAll;
  Contents.CopyToClipBoard;
end;

procedure TArc_Form.AddClick(Sender: TObject);
var
  f: TFileStream;
  n: integer;
  s: string;
begin
  OpenDialog.Options := [ofAllowMultiSelect, ofPathMustExist, ofFileMustExist];
  OpenDialog.Filter := 'TextFiles|*.txt|Rich Text Files|*.rtf|All Files|*.*';
  OpenDialog.Title := 'Select file(s) to add to the knowledge-base';
  OpenDialog.Execute;
  Screen.Cursor := crHourGlass;
  QDB.BeginUpdate;
  for n := 1 to OpenDialog.Files.Count do
  begin
    s := OpenDialog.Files[n - 1];
    if QDB.ExactMatch(s) then
    begin
      ShowMessage(s + ' is already in the knowledge-base')
    end
    else
    begin
    // notice how easy it is to store a file!
      f := TFileStream.Create(s, 0);
      try
        QDB.Add(f, s);
      finally
        f.Free;
      end;
    end;
  end;
  QDB.EndUpdate;
  Screen.Cursor := crDefault;
end;

procedure TArc_Form.PlainTextClick(Sender: TObject);
begin
  Contents.PlainText := PlainText.Checked;
  if PlainText.Checked then
    Contents.Font.Name := 'Courier New'
  else
    Contents.Font.Name := 'Arial';
  QDBNavigate(self);
end;

procedure TArc_Form.FindClick(Sender: TObject);
begin
  FindDialog.Execute;
end;

procedure TArc_Form.QDBNavigate(Sender: TObject);
var
  m: TMemoryStream;
begin
  Screen.Cursor := crHourGlass;
  m := TMemoryStream.Create;
  try
    QDB.Get(m);
    Contents.Lines.LoadFromStream(m);
  finally
    m.Free;
    Screen.Cursor := crDefault;
  end;
end;

// this is the hardest task to code ...

procedure TArc_Form.FindDialogFind(Sender: TObject);
var
  lastpos: integer;
  wordpos: integer;
  mytext: string;
begin
  lastpos := Contents.SelStart + Contents.SelLength;
  mytext := AnsiUpperCase(Copy(Contents.Text, lastpos + 1, Length(Contents.Text)));
  wordpos := Pos(AnsiUpperCase(FindDialog.FindText), mytext);
  if wordpos > 0 then
  begin
    Arc_Form.BringToFront;
    Arc_Form.ActiveControl := Contents;
    Contents.SelStart := lastpos + wordpos - 1;
    Contents.SelLength := Length(FindDialog.FindText);
  end
  else
  begin
    repeat
      QDB.NextItem;
    until QDB.EoF or (Pos(AnsiUpperCase(FindDialog.FindText), AnsiUpperCase(Contents.Text)) <> 0);
    lastpos := Contents.SelStart + Contents.SelLength;
    mytext := AnsiUpperCase(Copy(Contents.Text, lastpos + 1, Length(Contents.Text)));
    wordpos := Pos(AnsiUpperCase(FindDialog.FindText), mytext);
    if wordpos > 0 then
    begin
    // the selection will only show if Contents has the focus
      Arc_Form.BringToFront;
      Arc_Form.ActiveControl := Contents;
      Contents.SelStart := lastpos + wordpos - 1;
      Contents.SelLength := Length(FindDialog.FindText);
    end
    else
    begin
      ShowMessage('No more occurrences found');
    end;
  end;
end;

procedure TArc_Form.FormCreate(Sender: TObject);
begin
  MyDisable;
  Contents.Clear;
end;

procedure TArc_Form.QDBWarnNoData(Sender: TObject);
begin
// dummy
end;

end.