{$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;
|
