Delphi World - Word, OutLook и OLE

Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...

Word, OutLook и OLE

Здесь мы ответим на действительно интересные вопросы:

Как узнать, установлен ли Word 8 на машине клиента?
Где расположены шаблоны?
Почему запускается все время новый документ, когда я хочу работать в том же?
Как найти документ, с которым пользователь работал в последнее время?
Почему Word закрывается после завершения моей процедуры?
Как мне добраться до папок программы Outlook?
Как в Outlook получить доступ к существующему контакту или создать свой?

{--------------------Взято из библиотеки типов--------------- WORDDEC.INC}
Const
// OlAttachmentType

olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
// OlDefaultFolders

olFolderDeletedItems = 3;
olFolderOutbox = 4;
olFolderSentMail = 5;
olFolderInbox = 6;
olFolderCalendar = 9;
olFolderContacts = 10;
olFolderJournal = 11;
olFolderNotes = 12;
olFolderTasks = 13;
// OlFolderDisplayMode

olFolderDisplayNormal = 0;
olFolderDisplayFolderOnly = 1;
olFolderDisplayNoNavigation = 2;
// OlInspectorClose

olSave = 0;
olDiscard = 1;
olPromptForSave = 2;
// OlImportance

olImportanceLow = 0;
olImportanceNormal = 1;
olImportanceHigh = 2;
// OlItems

olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// OlSensitivity

olNormal = 0;
olPersonal = 1;
olPrivate = 2;
olConfidential = 3;
// OlJournalRecipientType;

olAssociatedContact = 1;
// OlMailRecipientType;

olOriginator = 0;
olTo = 1;
olCC = 2;
olBCC = 3;

Const

wdGoToBookmark = -1;
wdGoToSection = 0;
wdGoToPage = 1;
wdGoToTable = 2;
wdGoToLine = 3;
wdGoToFootnote = 4;
wdGoToEndnote = 5;
wdGoToComment = 6;
wdGoToField = 7;
wdGoToGraphic = 8;
wdGoToObject = 9;
wdGoToEquation = 10;
wdGoToHeading = 11;
wdGoToPercent = 12;
wdGoToSpellingError = 13;
wdGoToGrammaticalError = 14;
wdGoToProofreadingError = 15;


wdGoToFirst = 1;
wdGoToLast = -1;
wdGoToNext = 2;   //интересно,
wdGoToRelative = 2;  //чем отличаются эти две константы?
wdGoToPrevious = 3;
wdGoToAbsolute = 1;

Основные функции:

Function GetWordUp(StartType : string):Boolean;
Function InsertPicture(AFileName : String) : Boolean;
Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId): Boolean;
Function GetOutlookUp(ItemType : Integer): Boolean;
Function MakeOutLookContact(MyId : TMyId; MyContId : TMyContId) : Boolean;
Function ImportOutlookContact : Boolean;
Function GetOutlookFolderItemCount : Integer;
Function GetThisOutlookItem(AnIndex : Integer) : Variant;
Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :Boolean;
Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
Function CloseOutlook : Boolean;

Type TTreeData = class(TObject)

Public
ItemId : String;
end;

{$I worddec.inc} {все константы из библиотеки типов тащим с собой}

var

  myRegistry: TRegistry;
  GotWord: Boolean;
  WhereIsWord: string;
  WordDoneMessage: Integer;
  Basically: variant;
  Wordy: Variant;
  MyDocument: Variant;
  MyOutlook: Variant;
  MyNameSpace: Variant;
  MyFolder: Variant;
  MyAppointment: Variant;

function GetWordUp(StartType: string): Boolean;
// Запускаем Word "правильным" на мой взгляд способом
// после старта Word мы сделаем так, чтобы после завершения приложения он остался открытым
var
  i: integer;

  AHwnd: Hwnd;
  AnAnswer: Integer;
  temp: string;
  MyDocumentsCol: Variant;
  TemplatesDir: Variant;
  OpenDialog1: TopenDialog;

begin

  result := false;
  myRegistry := Tregistry.Create;
  myRegistry.RootKey := HKEY_LOCAL_MACHINE;
  // никакого "word 8", никакой функции!

  if myRegistry.KeyExists('SOFTWARE\Microsoft\Office\8.0\Word') then
    GotWord := true
  else
    GotWord := false;
  if GotWord then
    //где он, черт побери?

    if myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0', false) then
    begin
      WhereisWord := myRegistry.ReadString('BinDirPath');
      MyRegistry.CloseKey;
    end
    else
      GotWord := false;
  if GotWord then
    //и где эти надоевшие шаблоны?

  begin
    MyRegistry.RootKey := HKEY_CURRENT_USER;
    if
      myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0\Common\FileNew\SharedTemplates', false) then

    begin
      TemplatesDir := myRegistry.ReadString(Nothing);
      MyRegistry.CloseKey;
    end
    else
    begin
      Warning('Ole инсталляция', 'Шаблоны рабочей группы не установлены');
      GotWord := false;
    end;
  end;
  myRegistry.free;
  if not gotword then
  begin
    Warning('Ole дескриптор', 'Word не установлен');
    exit;
  end;
  //это имя класса принадлежит главному окну в двух последних версиях Word

  temp := 'OpusApp';
  AHwnd := FindWindow(pchar(temp), nil);
  if (AHwnd = 0) then
    //Word не запущен, пробуем запустить пустую оболочку без документа

  begin
    Temp := WhereisWord + '\winword.exe /n';
    AnAnswer := WinExec(pchar(temp), 1);
    if (AnAnswer < 32) then
    begin
      Warning('Ole дескриптор', 'Не могу найти WinWord.exe');
      Exit;
    end;
  end;

  Application.ProcessMessages;
  {Если вы уже используете Word.Application, вы получаете ваш собственный экземпляр}
  {Если вы уже используете Word.Document, вы получаете работающий экземпляр}
  {по-моему все понятно и очень удобно (во всяком случае мне)}

  try {создаем новый документ}
    Basically := CreateOleObject('Word.Document.8');
  except
    Warning('Ole дескриптор', 'Не могу запустить Microsoft Word.');
    Result := False;
    Exit;
  end;
  try {ссылаемся в переменной вариантного на вновь созданный документ}
    Wordy := Basically.Application;
  except
    begin
      Warning('Ole дескриптор', 'Не могу получить доступ к Microsoft Word.');
      Wordy := UnAssigned;
      Basically := UnAssigned;
      Exit;
    end;
  end;

  Application.ProcessMessages;

  Wordy.visible := false;
  MyDocumentsCol := Wordy.Documents;
  {Проверяем количество открытых документов и пытаемся вывести диалог выбора шаблона}

  if (MyDocumentsCol.Count = 1) or
    (StartType = 'New') then
  begin
    OpenDialog1 := TOpenDialog.Create(Application);
    OpenDialog1.filter := 'Шаблоны Word|*.dot|Документы Word|*.doc';
    OpenDialog1.DefaultExt := '*.dot';
    OpenDialog1.Title := 'Выберите ваш шаблон';
    OpenDialog1.InitialDir := TemplatesDir;
    if OpenDialog1.execute then
    begin
      Wordy.ScreenUpdating := false;
      MyDocumentsCol := wordy.Documents;
      MyDocumentsCol.Add(OpenDialog1.Filename, False);
      OpenDialog1.free;
    end
    else
    begin
      OpenDialog1.Free;
      Wordy.visible := true;
      Wordy := Unassigned;
      Basically := Unassigned;
      Exit;
    end;
  end
  else
    {закрываем документ}

    MyDocument.close(wdDoNotSaveChanges);

  {теперь мы имеем или новый документ на основе шаблона, выбранного пользователем

  или же его текущий документ}
  MyDocument := Wordy.ActiveDocument;
  Result := true;
  Application.ProcessMessages;

end;

function InsertPicture(AFileName: string): Boolean;
var

  MyShapes: Variant;
  MyRange: variant;

begin

  Result := True;
  if GetWordUp('Current') then
  try
    begin
      MyRange := MyDocument.goto(wdgotoline, wdgotolast);
      MyRange.EndOf(wdParagraph, wdMove);
      MyRange.InsertBreak(wdPageBreak);
      MyShapes := MyDocument.InlineShapes;
      MyShapes.AddPicture(afilename, false, true, MyRange);
    end;
  finally
    begin
      Wordy.ScreenUpdating := true;
      Wordy.visible := true;
      Wordy := Unassigned;
      Basically := UnAssigned;
      Application.ProcessMessages;
    end;
  end
  else
    Result := False;

end;

function InsertContactInfo(MyId: TMyId; MyContId: TMyContId): Boolean;
var

  MyCustomProps: Variant;
begin
  { лично я сначала сохраняю свою визитку в свойствах документа, а только
  потом вывожу панели с инструментами для того, чтобы пользователь мог
  "установить" принадлежность шаблона или текущего документа.

  на мой взгляд здесь есть три достоинства (здесь нет подвохов, уверяю вас):
  1. Пользователь может установить свои свойства документа после того,
  как функция отработает
  2. Другие свойства могут быть установлены в любом месте
  того же документа
  3. Пользователь может переслать эти свойства в тот же Outlook или с их
  помощью найти документ, используя функции расширенного поиска Word}

  Result := true;
  if GetWordUp('New') then
  try
    begin
      MyCustomProps := MyDocument.CustomDocumentProperties;
      MyCustomProps.add(cpId, false, msoPropertyTypeString, MyId.Id);
      MyCustomProps.add(cpOrganizationName,
        false, msoPropertyTypeString, MyId.OrganizationName);
      MyCustomProps.add(cpAddress1,
        false, msoPropertyTypeString, MyId.Address1);
      MyCustomProps.add(cpAddress2, false,
        msoPropertyTypeString, MyId.Address2);
      MyCustomProps.add(cpCity, false,
        msoPropertyTypeString, MyId.City);
      MyCustomProps.add(cpStProv, false,
        msoPropertyTypeString, MyId.StProv);
      MyCustomProps.add(cpCountry,
        false, msoPropertyTypeString, MyId.City);
      MyCustomProps.add(cpPostal, false,
        msoPropertyTypeString, MyId.Country);
      MyCustomProps.add(cpAccountId, false,
        msoPropertyTypeString, MyId.AccountId);
      MyCustomProps.add(cpFullName, false,
        msoPropertyTypeString, MyContId.FullName);
      MyCustomProps.add(cpSalutation, false,
        msoPropertyTypeString, MyContId.Salutation);
      MyCustomProps.add(cpTitle, false,
        msoPropertyTypeString, MyContId.Title);
      if (MyContId.workPhone = Nothing) or
        (MycontId.WorkPhone = ASpace) then
        MyCustomProps.add(cpPhone, false,
          msoPropertyTypeString, MyId.Phone)
      else
        MyCustomProps.add(cpPhone, false,
          msoPropertyTypeString, MyContId.WorkPhone);
      if (MyContId.Fax = Nothing) or (MycontId.Fax = ASpace) then
        MyCustomProps.add(cpFax, false,
          msoPropertyTypeString, MyId.Fax)
      else
        MyCustomProps.add(cpFax, false,
          msoPropertyTypeString, MyContId.Fax);
      if (MyContId.EMail = Nothing) or (MycontId.Email = ASpace) then
        MyCustomProps.add(cpEmail, false,
          msoPropertyTypeString, MyId.Email)
      else
        MyCustomProps.add(cpEmail, false,
          msoPropertyTypeString, MyContId.Email);
      MyCustomProps.add(cpFirstName, false,
        msoPropertyTypeString, MyContId.FirstName);
      MyCustomProps.add(cpLastName, false,
        msoPropertyTypeString, MyContId.LastName);
      MyDocument.Fields.Update;
    end;
  finally
    begin
      Wordy.ScreenUpdating := true;
      Wordy.visible := true;
      Wordy := Unassigned;
      Basically := UnAssigned;
      Application.ProcessMessages;
    end;
  end
  else
    Result := false;
end;

function GetOutlookUp(ItemType: Integer): Boolean;
const

  AppointmentItem = 'Calendar';
  TaskItem = 'Tasks';
  ContactItem = 'Contacts';
  JournalItem = 'Journal';
  NoteItem = 'Notes';
var

  MyFolders: Variant;
  MyFolders2: variant;
  MyFolders3: variant;
  MyFolder2: Variant;
  MyFolder3: variant;
  MyUser: Variant;
  MyFolderItems: Variant;
  MyFolderItems2: Variant;
  MyFolderItems3: Variant;
  MyContact: Variant;
  i, i2, i3: Integer;
  MyTree: TCreateCont;
  MyTreeData: TTreeData;
  RootNode, MyNode, MyNode2: ttreeNode;
  ThisName: string;

begin

  {это действительно безобразие........
  В Outlook несколько странно реализована объектная модель,
  и такие перлы как folder.folder.folder считаются "верным решением"
  для получения доступа к папкам этой великолепной программы.}

  {пользователь выбирает папку из дерева папок}

  Result := False;
  case ItemType of
    olAppointmentItem: ThisName := AppointmentItem;
    olContactItem: ThisName := ContactItem;
    olTaskItem: ThisName := TaskItem;
    olJournalItem: ThisName := JournalItem;
    olNoteItem: ThisName := NoteItem;
  else
    ThisName := 'Unknown';
  end;

  try
    MyOutlook := CreateOleObject('Outlook.Application');
  except
    warning('Ole интерфейс', 'Не могу запустить Outlook.');
    Exit;
  end;
  {это папка верхнего уровня}
  MyNameSpace := MyOutlook.GetNamespace('MAPI');
  MyFolderItems := MyNameSpace.Folders;
  MyTree := TCreateCont.create(Application);
  {Действительно неудачно, ведь пользователь может создать что-то другое,
  чем папки, предлагаемые по-умолчанию, на которые мы и хотели опереться
  в нашей программе, поэтому перемещаемся на нижний уровень в цепочке папок}

  MyTree.Caption := 'Выбрана ' + ThisName + ' папка';
  with MyTree do
    if MyFolderItems.Count > 0 then
      for i := 1 to MyFolderItems.Count do
      begin
        MyFolder := MyNameSpace.Folders(i);
        MyTreeData := TTreeData.create;
        MyTreeData.ItemId := MyFolder.EntryId;
        RootNode := TreeView1.Items.AddObject(nil, MyFolder.Name, MyTreeData);
        MyFolders2 := MyNameSpace.folders(i).Folders;
        if MyFolders2.Count > 0 then
          for i2 := 1 to MyFolders2.Count do
          begin
            MyFolder2 := MyNameSpace.folders(i).Folders(i2);
            if (MyFolder2.DefaultItemType = ItemType)
              or (MyFolder2.Name = ThisName) then
            begin
              MyTreeData := TTreeData.create;
              MyTreeData.ItemId := MyFolder2.EntryId;
              {вот мы и добрались непосредственно до папок}

              MyNode :=
                Treeview1.Items.addChildObject(RootNode, MyFolder2.Name,
                  MyTreeData);

              MyFolders3 :=
                MyNameSpace.folders(i).Folders(i2).Folders;

              if MyFolders3.Count > 0 then
                for i3 := 1 to MyFolders3.Count do
                begin
                  MyFolder3 := MyNameSpace.folders(i).Folders(i2).Folders(i3);
                  if (MyFolder3.DefaultItemType = ItemType) then
                  begin
                    MyTreeData := TTreeData.create;
                    MyTreeData.ItemId := MyFolder3.EntryId;
                    MyNode2 :=
                      Treeview1.Items.addChildObject(MyNode, MyFolder3.Name,
                        MyTreeData);

                  end;
                end;
            end;
          end;
      end;
  if MyTree.TreeView1.Items.Count = 2 then
    {есть только корневая папка и папка, определенная мной}

    MyFolder :=
      MyNameSpace.GetFolderFromID(TTreeData(MyTree.TreeView1.Items[1].Data).ItemId
      )

  else
  begin
    MyTree.Treeview1.FullExpand;
    MyTree.ShowModal;
    if MyTree.ModalResult = mrOk then
    begin
      if MyTree.Treeview1.Selected <> nil then
        MyFolder :=
          MyNameSpace.GetFolderFromID(TTreeData(MyTree.Treeview1.Selected.Data).ItemId
          );

    end
    else
    begin
      MyOutlook := UnAssigned;
      for i := MyTree.Treeview1.Items.Count - 1 downto 0 do
        TTreeData(MyTree.Treeview1.Items[i].Data).free;
      MyTree.release;
      exit;
    end;
  end;
  for i := MyTree.Treeview1.Items.Count - 1 downto 0 do
    TTreeData(MyTree.Treeview1.Items[i].Data).free;
  MyTree.release;
  Result := true;
end;

function MakeOutlookContact(MyId: TMyId; MyContId: TMyContId): boolean;
var
  MyContact: Variant;
begin

  Result := false;
  if not GetOutlookUp(OlContactItem) then
    exit;
  MyContact := MyFolder.Items.Add(olContactItem);
  MyContact.Title := MyContId.Honorific;
  MyContact.FirstName := MyContId.FirstName;
  MyContact.MiddleName := MycontId.MiddleInit;
  MyContact.LastName := MycontId.LastName;
  MyContact.Suffix := MyContId.Suffix;
  MyContact.CompanyName := MyId.OrganizationName;
  MyContact.JobTitle := MyContId.Title;
  MyContact.OfficeLocation := MyContId.OfficeLocation;
  MyContact.CustomerId := MyId.ID;
  MyContact.Account := MyId.AccountId;
  MyContact.BusinessAddressStreet := MyId.Address1 + CRLF + MyId.Address2;
  MyContact.BusinessAddressCity := MyId.City;
  MyContact.BusinessAddressState := MyId.StProv;
  MyContact.BusinessAddressPostalCode := MyId.Postal;
  MyContact.BusinessAddressCountry := MyId.Country;
  if (MyContId.Fax = Nothing) or (MyContId.Fax = ASpace) then
    MyContact.BusinessFaxNumber := MyId.Fax
  else
    MyContact.BusinessFaxNumber := MyContId.Fax;
  if (MyContId.WorkPhone = Nothing) or (MyContId.WorkPhone = ASpace) then

    MyContact.BusinessTelephoneNumber := MyId.Phone
  else
    MyContact.BusinessTelephoneNumber := MyContId.WorkPhone;
  MyContact.CompanyMainTelephoneNumber := MyId.Phone;
  MyContact.HomeFaxNumber := MyContId.HomeFax;
  MyContact.HomeTelephoneNumber := MyContId.HomePhone;
  MyContact.MobileTelephoneNumber := MyContId.MobilePhone;
  MyContact.OtherTelephoneNumber := MyContId.OtherPhone;
  MyContact.PagerNumber := MyContId.Pager;
  MyContact.Email1Address := MyContId.Email;
  MyContact.Email2Address := MyId.Email;
  Result := true;
  try
    MyContact.Save;
  except
    Result := false;
  end;
  MyOutlook := Unassigned;

end;

function GetThisOutlookItem(AnIndex: Integer): Variant;
begin

  Result := myFolder.Items(AnIndex);
end;

function GetOutlookFolderItemCount: Integer;
var
  myItems: Variant;
begin

  try
    MyItems := MyFolder.Items;
  except
    begin
      Result := 0;
      exit;
    end;
  end;
  Result := MyItems.Count;
end;

function FindMyOutlookItem(AFilter: string; var AItem: Variant):
  Boolean;
begin
  {не забудьте предварительно инициализировать AItem значением NIL}

  Result := true;
  try
    AItem := myFolder.Items.Find(AFilter);
  except
    begin
      aItem := MyFolder;
      Result := false;
    end;
  end;

end;

function FindNextMyOutlookItem(var AItem: Variant): Boolean;
begin

  Result := true;
  try
    AItem := myFolder.Items.FindNext;
  except
    begin
      AItem := myFolder;
      Result := false;
    end;
  end;
end;

function CloseOutlook: Boolean;
begin

  try
    MyOutlook := Unassigned;
  except
  end;
  Result := true;

end;

Как использовать весь этот код?
Вот модуль для работы с Контактами программы Outlook.
Строим расширенный список контактов (компонент TExtListView вы можете найти на www.torry.ru).

unit UImpContact;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  UMain, StdCtrls, Buttons, ComCtrls, ExtListView;

type

  TFindContact = class(TForm)
    ContView1: TExtListView;
    SearchBtn: TBitBtn;
    CancelBtn: TBitBtn;
    procedure SearchBtnClick(Sender: TObject);
    procedure CancelBtnClick(Sender: TObject);
    procedure ContView1DblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  FindContact: TFindContact;

implementation
uses USearch;

{$R *.DFM}

procedure TFindContact.SearchBtnClick(Sender: TObject);
begin

  if ContView1.Selected <> nil then
    ContView1DblClick(nil);
end;

procedure TFindContact.CancelBtnClick(Sender: TObject);
begin

  CloseOutlook;
  ModalResult := mrCancel;
end;

procedure TFindContact.ContView1DblClick(Sender: TObject);
var
  MyContact: variant;
begin

  if ContView1.Selected <> nil then
  begin
    MyContact := GetThisOutlookItem(StrToInt(ContView1.Selected.subitems[2]));
    with StartForm.MyId do
      if not GetData(MyContact.CustomerId) then
      begin
        InitData;
        if MyContact.CustomerId <> '' then
          Id := MyContact.CustomerId
        else
          Id := MyContact.CompanyName;
        if DoesIdExist(Startform.MyId.Id) then
        begin
          Warning('Дескриптор данных', 'Не могу установить уникальный Id' + CRLF
            + 'Отредактируйте CustomerId в Outlook и попытайтесь снова');
          CloseOutlook;
          ModalResult := mrCancel;
          Exit;
        end;
        OrganizationName := MyContact.CompanyName;
        IdType := 1;
        AccountId := MyContact.Account;
        Address1 := MyContact.BusinessAddressStreet;
        City := MyContact.BusinessAddressCity;
        StProv := MyContact.BusinessAddressState;
        Postal := MyContact.BusinessAddressPostalCode;
        Country := MyContact.BusinessAddressCountry;
        Phone := MyContact.CompanyMainTelephoneNumber;
        Insert;
      end;
    with StartForm.MyContId do
    begin
      InitData;
      ContIdId := StartForm.MyId.Id;
      Honorific := MyContact.Title;
      FirstName := MyContact.FirstName;
      MiddleInit := MyContact.MiddleName;
      LastName := MyContact.LastName;
      Suffix := MyContact.Suffix;
      Fax := MyContact.BusinessFaxNumber;
      WorkPhone := MyContact.BusinessTelephoneNumber;
      HomeFax := MyContact.HomeFaxNumber;
      HomePhone := MyContact.HomeTelephoneNumber;
      MobilePhone := MyContact.MobileTelephoneNumber;
      OtherPhone := MyContact.OtherTelephoneNumber;
      Pager := MyContact.PagerNumber;
      Email := MyContact.Email1Address;
      Title := MyContact.JobTitle;
      OfficeLocation := MyContact.OfficeLocation;
      Insert;
    end;
  end;
  CloseOutlook;
  ModalResult := mrOk;

end;

procedure TFindContact.FormCreate(Sender: TObject);
var
  MyContact: Variant;

  MyCount: Integer;
  i: Integer;
  AnItem: TListItem;
begin

  if not GetOutlookUp(OlContactItem) then
    exit;
  MyCount := GetOutlookFolderItemCount;
  for i := 1 to MyCount do
  begin
    MyContact := GetThisOutlookItem(i);
    AnItem := ContView1.Items.Add;
    AnItem.Caption := MyContact.CompanyName;
    AnItem.SubItems.add(MyContact.FirstName);
    AnItem.Subitems.Add(MyContact.LastName);
    AnItem.SubItems.Add(inttostr(i));
  end;

end;

procedure TFindContact.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := cafree;
end;

end.