Delphi / MS Office 97 / OLE / VB для приложений

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

Как узнать, установлен ли 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;

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;

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;

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;

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;

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;

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.

[000187]