Советы по Delphi

         

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; 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.

    [000187]



    Содержание раздела