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.