Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/QDB/ADDBOOK.ZIP/AB_main.pas

Pascal/Delphi Source File | 1998-06-28 | 11.7 KB | 451 lines

{*****************************************************************************}
{                                                                             }
{                             Address Book Demo                               }
{                                                                             }
{                     illustrating the use of the                             }
{                                                                             }
{            QDB v2.10 Visual Components for Delphi 1, 2, & 3                 }
{                                                                             }
{          Copyright (c) 1995, 1996, 1997, 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 add_book and find yourself using it please                }
{       consider making a donation to your favorite charity.                  }
{                                                                             }
{    Users of add_book must accept the following disclaimer of warranty:      }
{                                                                             }
{       add_book 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 add_book.             }
{                                                                             }
{*****************************************************************************}

unit AB_main;

interface

uses
  SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, Menus, QDB;

type
  TAB_form = class(TForm)
    MainMenu: TMainMenu;
    FileNewItem: TMenuItem;
    FileOpenItem: TMenuItem;
    FileSaveItem: TMenuItem;
    FileCloseItem: TMenuItem;
    FileExitItem: TMenuItem;
    StatusLine: TPanel;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    Addresses: TQDB;
    SpeedBar: TPanel;
    FileNewSButton: TSpeedButton;
    FileOpenSButton: TSpeedButton;
    FileSaveSButton: TSpeedButton;
    FileCloseSButton: TSpeedButton;
    FileExitSButton: TSpeedButton;
    ListPanel: TPanel;
    KeyList: TListBox;
    EntryPanel: TPanel;
    AddBox: TMemo;
    IsPerson: TCheckBox;
    HPhone: TEdit;
    WPhone: TEdit;
    FPhone: TEdit;
    E_Mail: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label6: TLabel;
    ButtonPanel: TPanel;
    AddButton: TButton;
    ClearButton: TButton;
    DeleteButton: TButton;
    Image: TImage;
    procedure FormCreate(Sender: TObject);
    procedure ShowHint(Sender: TObject);
    procedure FileNew(Sender: TObject);
    procedure FileOpen(Sender: TObject);
    procedure FileSave(Sender: TObject);
    procedure FileClose(Sender: TObject);
    procedure FileExit(Sender: TObject);
    procedure HelpContents(Sender: TObject);
    procedure AddButtonClick(Sender: TObject);
    procedure ClearButtonClick(Sender: TObject);
    procedure DeleteButtonClick(Sender: TObject);
    procedure KeyListClick(Sender: TObject);
    procedure AddressesProgressUpdate(Sender: TObject;
      Percent: TPercentage; Kind: TProgressOrigin);
  private
    procedure BlankEntries;
    procedure MyActivate;
    procedure MyDeActivate;
    procedure ScreenToItem(P: PChar; var PLen: word);
    procedure ItemToScreen(P: PChar);
    function CurrentKey: TKey;
    procedure MyUpdate;
  end;

var
  AB_form: TAB_form;

implementation

{$R *.DFM}

{invert a name to put the surname first}
{e.g. Robert R. Marsh => Marsh, Robert R.}

function NameToKey(Name: string): string;

  {return first position of a char after position n}
  function PosCAfter(c: char; s: string; n: integer): integer;
  var
    i: integer;
  begin
    Result := 0;
    for i := n + 1 to Length(s) do
      if s[i] = c then
      begin
        Result := i;
        Break;
      end;
  end;

{$IFNDEF WIN32}
  procedure TrimLeft(var s: string);
  begin
    while s[1] = ' ' do Delete(s, 1, 1);
  end;

  procedure TrimRight(var s: string);
  begin
    while s[length(s)] = ' ' do delete(s, length(s), 1);
  end;
{$ENDIF}

var
  NewName: string;
  CommaPos: Byte;
  SpacePos: Byte;
  LastSpacePos: Byte;
begin
  NewName := Name;
  TrimLeft(NewName);
{ then remove anything after a comma, e.g. strip off the S.J.'s}
  CommaPos := PosCAfter(',', NewName, 0);
  if CommaPos <> 0 then
    NewName := Copy(NewName, 1, CommaPos - 1);
{ now strip off trailing spaces and see if anything is left }
  TrimRight(NewName);
  if Length(NewName) = 0 then
  begin
    Result := '';
    Exit;
  end;
{ finally, find the last space in the name and take it to delimit the surname }
  LastSpacePos := 1;
  SpacePos := 1;
  while SpacePos <> 0 do
  begin
    LastSpacePos := SpacePos;
    SpacePos := PosCAfter(' ', NewName, SpacePos);
  end;
{ then just invert the order }
  if LastSpacePos = 1 then
    Result := NewName
  else
    Result := Copy(NewName, LastSpacePos + 1, high(integer)) + ', ' + Copy(NewName, 1, LastSpacePos - 1);
end;

const
  MaxSize = 400; {largest item possible}
  BaseTitle = 'Address Book Demo';

procedure TAB_form.FormCreate(Sender: TObject);
begin
  Application.OnHint := ShowHint;
  AB_form.Caption := BaseTitle;
  MyDeActivate;
end;

procedure TAB_form.ShowHint(Sender: TObject);
begin
  StatusLine.Caption := Application.Hint;
end;

procedure TAB_form.FileNew(Sender: TObject);
var
  NewFileName: string;
begin
  if SaveDialog.Execute then
  begin
    NewFileName := SaveDialog.FileName;
    if FileExists(NewFileName) then SysUtils.DeleteFile(NewFileName);
    Addresses.FileName := NewFileName;
    AB_form.Caption := BaseTitle + ' - ' + ExtractFileName(Addresses.FileName);
    KeyList.Items.Clear;
    MyUpdate;
    MyActivate;
  end;
end;

procedure TAB_form.FileOpen(Sender: TObject);
begin
  if OpenDialog.Execute then
  begin
    Addresses.FileName := OpenDialog.FileName;
    Addresses.CacheSize := 8 * 1024;
    BlankEntries;
    Addresses.AssignKeyList(KeyList.Items);
    if KeyList.Items.Count > 0 then
    begin
      KeyList.ItemIndex := 0;
      MyUpdate;
    end;
    AB_form.Caption := BaseTitle + ' - ' + ExtractFileName(Addresses.FileName);
    MyActivate;
  end;
end;

procedure TAB_form.FileSave(Sender: TObject);
begin
  Addresses.Save;
  Addresses.Pack;
end;

procedure TAB_form.FileExit(Sender: TObject);
begin
  if Addresses.FileName <> '' then
  begin
    Addresses.FileName := '';
  end;
  Close;
end;

procedure TAB_form.HelpContents(Sender: TObject);
begin
  Application.HelpCommand(HELP_CONTENTS, 0);
end;

procedure TAB_form.FileClose(Sender: TObject);
begin
  Addresses.Save;
  Addresses.Pack;
  Addresses.FileName := '';
  BlankEntries;
  KeyList.Items.Clear;
  AB_form.Caption := BaseTitle;
  MyDeActivate;
end;

{pack the data on the screen into an item we can store}

procedure TAB_form.ScreenToItem(P: PChar; var PLen: word);
var
  PP: PChar;
begin
  PP := P;
  StrPCopy(PP, AddBox.Text);
  inc(PP, StrLen(PP) + 1);
  if IsPerson.Checked then
  begin
    StrPCopy(PP, 'Y');
    inc(PP, StrLen(PP) + 1);
  end
  else
  begin
    StrPCopy(PP, 'N');
    inc(PP, StrLen(PP) + 1);
  end;
  StrPCopy(PP, HPhone.Text);
  inc(PP, StrLen(PP) + 1);
  StrPCopy(PP, WPhone.Text);
  inc(PP, StrLen(PP) + 1);
  StrPCopy(PP, FPhone.Text);
  inc(PP, StrLen(PP) + 1);
  StrPCopy(PP, E_Mail.Text);
  inc(PP, StrLen(PP) + 1);
  PLen := PP - P + 1;
end;

{unpack an item onto the screen}

procedure TAB_form.ItemToScreen(P: PChar);
var
  PP: PChar;
begin
  Addresses.GetItem(P);
  PP := P;
  AddBox.SetTextBuf(PP);
  inc(PP, StrLen(PP) + 1);
  IsPerson.Checked := (StrPas(PP) = 'Y');
  inc(PP, StrLen(PP) + 1);
  HPhone.Text := StrPas(PP);
  inc(PP, StrLen(PP) + 1);
  WPhone.Text := StrPas(PP);
  inc(PP, StrLen(PP) + 1);
  FPhone.Text := StrPas(PP);
  inc(PP, StrLen(PP) + 1);
  E_Mail.Text := StrPas(PP);
end;

procedure TAB_form.BlankEntries;
begin
  AddBox.Text := '';
  IsPerson.Checked := true;
  HPhone.Text := '';
  WPhone.Text := '';
  FPhone.Text := '';
  E_Mail.Text := '';
  AddBox.SetFocus;
end;

procedure TAB_form.MyActivate;
begin
  AddButton.Enabled := true;
  ClearButton.Enabled := true;
  DeleteButton.Enabled := true;
end;

procedure TAB_form.MyDeActivate;
begin
  AddButton.Enabled := false;
  ClearButton.Enabled := false;
  DeleteButton.Enabled := false;
end;

function TAB_form.CurrentKey: TKey;
var
  ThisItem: integer;
begin
  if KeyList.Items.Count > 0 then
  begin
    ThisItem := KeyList.ItemIndex;
    if ThisItem < 0 then
    begin
      Result := '';
    end
    else
    begin
      Result := KeyList.Items[ThisItem];
    end;
  end
  else
  begin
    Result := '';
  end;
end;

procedure TAB_form.AddButtonClick(Sender: TObject);
var
  NewKey: TKey;
  Item: PChar;
  ItemLen: word;
begin
  NewKey := NameToKey(AddBox.Lines[0]);
  if NewKey <> '' then
  begin
    if NewKey <> CurrentKey then {Add}
    begin
      GetMem(Item, MaxSize);
      try
        ScreenToItem(Item, ItemLen);
        Addresses.AddItem(Item, ItemLen, NewKey);
      finally
        FreeMem(Item, Maxsize);
      end;
      Addresses.AssignKeyList(KeyList.Items);
      KeyList.ItemIndex := KeyList.Items.IndexOf(NewKey);
    end
    else {Change}
    begin
      GetMem(Item, MaxSize);
      try
        ScreenToItem(Item, ItemLen);
        if Addresses.ExactMatch(NewKey) then
          Addresses.ChangeItem(Item, ItemLen);
      finally
        FreeMem(Item, MaxSize);
      end;
    end;
  end
  else
  begin
    ShowMessage('No address to add');
  end;
end;

procedure TAB_form.ClearButtonClick(Sender: TObject);
begin
  BlankEntries;
end;

procedure TAB_form.DeleteButtonClick(Sender: TObject);
var
  ThisItem: integer;
  KeyToGo: string;
begin
  ThisItem := KeyList.ItemIndex;
  if ThisItem <> -1 then
  begin
    KeyToGo := KeyList.Items[ThisItem];
    if Addresses.ExactMatch(KeyToGo) then
    begin
      Addresses.DeleteItem;
      Addresses.AssignKeyList(KeyList.Items);
    end;
  end;
  if ThisItem >= KeyList.Items.Count then
  begin
    dec(ThisItem);
  end;
  KeyList.ItemIndex := ThisItem;
  MyUpdate;
end;

procedure TAB_form.KeyListClick(Sender: TObject);
begin
  MyUpdate;
end;

procedure TAB_form.MyUpdate;
var
  ThisKey: TKey;
  ThisItem: PChar;
begin
  ThisKey := CurrentKey;
  if Addresses.ExactMatch(ThisKey) then
  begin
    ThisItem := StrAlloc(Addresses.ItemSize);
    ItemToScreen(ThisItem);
    StrDispose(ThisItem);
  end
  else
  begin
    BlankEntries;
  end;
end;

procedure TAB_form.AddressesProgressUpdate(Sender: TObject;
  Percent: TPercentage; Kind: TProgressOrigin);
begin
  StatusLine.Caption := IntToStr(Percent);
end;

end.