Советы по Delphi
Delphi / MS Office 97 / OLE / VB для приложений
Здесь мы ответим на действительно интересные вопросы:
|
{--------------------Взято из библиотеки типов--------------- 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]
