Word, OutLook и OLE

{--------------------Взято из библиотеки типов--------------- 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;

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.