Вопрос:
Мне нужно скопировать поля имени, темы и полученной даты из электронных писем, полученных во входящих папках Outlook 2007/2010, подпапках и общих папках в Excel 2007/2010.
Также, когда я экспортирую в Excel, он должен добавлять данные каждый раз, когда я запускаю макрос.
Этот код, который я получил в Интернете, позволяет мне выбрать папку, но не множественный выбор. Есть ли способ выбрать несколько папок.
Исходная ссылка на код: https://web.archive.org/web/1/http://i.techrepublic%2ecom%2ecom/downlo…k_to_excel.zip
Sub ExportToExcel() On Error GoTo ErrHandler Dim appExcel As Excel.Application Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Dim rng As Excel.Range Dim strSheet As String Dim strPath As String Dim intRowCounter As Integer Dim intColumnCounter As Integer Dim msg As Outlook.MailItem Dim nms As Outlook.NameSpace Dim fld As Outlook.MAPIFolder Dim itm As Object strSheet = «OutlookItems.xls» strPath = «C:Examples» strSheet = strPath & strSheet Debug.Print strSheet ‘Select export folder Set nms = Application.GetNamespace(«MAPI») Set fld = nms.PickFolder ‘Handle potential errors with Select Folder dialog box. If fld Is Nothing Then MsgBox «There are no mail messages to export», vbOKOnly, _ «Error» Exit Sub ElseIf fld.DefaultItemType <> olMailItem Then MsgBox «There are no mail messages to export», vbOKOnly, _ «Error» Exit Sub ElseIf fld.Items.Count = 0 Then MsgBox «There are no mail messages to export», vbOKOnly, _ «Error» Exit Sub End If ‘Open and activate Excel workbook. Set appExcel = CreateObject(«Excel.Application») appExcel.Workbooks.Open (strSheet) Set wkb = appExcel.ActiveWorkbook Set wks = wkb.Sheets(1) wks.Activate appExcel.Application.Visible = True ‘Copy field items in mail folder. For Each itm In fld.Items intColumnCounter = 1 Set msg = itm intRowCounter = intRowCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.Value = msg.To intColumnCounter = intColumnCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.Value = msg.SenderEmailAddress intColumnCounter = intColumnCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.Value = msg.Subject intColumnCounter = intColumnCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.Value = msg.SentOn intColumnCounter = intColumnCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.Value = msg.ReceivedTime Next itm Set appExcel = Nothing Set wkb = Nothing Set wks = Nothing Set rng = Nothing Set msg = Nothing Set nms = Nothing Set fld = Nothing Set itm = Nothing Exit Sub ErrHandler: If Err.Number = 1004 Then MsgBox strSheet & » doesn’t exist», vbOKOnly, _ «Error» Else MsgBox Err.Number & «; Description: «, vbOKOnly, _ «Error» End If Set appExcel = Nothing Set wkb = Nothing Set wks = Nothing Set rng = Nothing Set msg = Nothing Set nms = Nothing Set fld = Nothing Set itm = Nothing End Sub Ответ №1
Позвольте немного сломать вашу задачу… насколько я вижу, вам нужно будет написать код, возможно, также пользовательскую форму, чтобы захватить точку входа в структуру вашей MAPI-папки и, возможно, параметр даты (элементы после D…) в Outlook VBA. Тогда есть три основные части проблемы
- пройдите через свое дерево MAPI Folders – из выбранной начальной точки
- идентифицировать соответствующие объекты (элементы почты… в папках могут быть и другие элементы)
- захватить некоторые данные о соответствующих объектах и записать их в Excel
ad 1: это, скорее всего, будет рекурсивной задачей, чтобы перейти к нижней части структуры папок с определенной начальной точки (root или любой папки, которую пользователь может выбрать). Поэтому я лично был бы осторожен с общими общими папками, поскольку они могли бы скрыть ОГРОМНОЕ количество папок/элементов и открыть всевозможные проблемы (чрезмерное время выполнения, ограничения доступа и т.д.). Кроме того, вы, вероятно, не хотите захватывать почтовые элементы в папке “Удаленные элементы” и ее подпрограмме. Также вы можете передать параметр DATE такой рекурсивной процедуре, введенной пользователем, для захвата элементов, созданных/отправленных за определенную дату.
здесь блок кода, который вы можете использовать для заполнения объекта treeview в пользовательской форме, который запрашивает корневую папку MAPI рекурсии и реагирует на кнопку EXPORT (см. ниже)
Private Sub UserForm_Initialize() Dim N As NameSpace, F As MAPIFolder Set N = Application.GetNamespace(«MAPI») ‘ load all main folders (and their subfolders) into TreeView_Source For Each F In N.Folders ‘ in my own app I don’t do the Public folder, this would be too massive If F.Name <> «Public Folders» Then LoadFolder TreeView_Source, F End If Next F Set F = Nothing Set N = Nothing End Sub Private Sub LoadFolder(TreeViewObj As MSComctlLib.TreeView, F As MAPIFolder, Optional Base As String = «») Dim G As MAPIFolder With TreeViewObj If Base = «» Then ‘ add as a root folder .Nodes.Add , tvwChild, F.EntryID, F.Name Else ‘ add as a child folder connected to Base .Nodes.Add Base, tvwChild, F.EntryID, F.Name End If End With ‘ recursive call to process subfolders of current folder For Each G In F.Folders LoadFolder TreeViewObj, G, F.EntryID Next G Set G = Nothing End Sub
объявление 2: это легко…
If TypeName(MyItem) = «MailItem» Then
ad 3: вам нужно выбрать, будете ли вы записывать данные своего элемента в структуре памяти (массив, независимо) и воспроизводить его в Excel в конце процесса или если вы хотите постоянно обновлять листы Excel, которые вы открыли на начало (со всеми проблемами объекта с глобальным уменьшением, счетчиком строк и т.д. Я оставляю это открытым пока.
Здесь кое-что, что я извлек из аналогичного квеста, которое я сделал сам. Я изменил его так, как если бы это повлияло на кнопку “Экспорт” маленького диалогового окна пользователя:
Примечание: BeforeDate действительно является AfterDate в этом случае
Private Sub CommandButton_Export_Click() Dim N As NameSpace, D As Date, S As MAPIFolder D = CDate(«01-Jän-2011») ‘ or from a field of your user form ‘ mind the Umlaut …. ‘ yeep I’m from Austria and we speak German 😉 ‘ initialize objects Set N = Application.GetNamespace(«MAPI») Set S = N.GetFolderFromID(TreeView_Source.SelectedItem.Key) ‘ this refers to a control named TreeView_Source in the current User Dialog form ProcessFolder S, D End Sub Private Sub ProcessFolder(Source As MAPIFolder, BeforeDate As Date) ‘ process MailItems of folder Source ‘ recurse for all subfolders of Source Dim G As MAPIFolder, Idx As Long, Icnt As Long, ObjDate As Date ‘ process mail items of current folder If Source.Items.Count <> 0 Then For Idx = 1 To Source.Items.Count ‘ now this is what I mentioned in «ad 2:» If TypeName(Source.Items(Idx)) = «MailItem» Then If BeforeDate = 0 Or Source.Items(Idx).ReceivedTime >= BeforeDate Then ProcessItem Source.Items(Idx) End If End If Next Idx End If ‘ go down into sub folders If Source.Folders.Count <> 0 Then For Idx = 1 To Source.Folders.Count ‘ here a folder named «Deleted Items» could be trapped ProcessFolder Source.Folders(Idx), BeforeDate Next Idx End If End Sub Sub ProcessItem(SrcItem As MailItem) ‘ here the capturing and eventually the writeout to Excel would occur ‘ for now I just have key fields printed in the debug screen With SrcItem Debug.Print .ReceivedTime, .ReceivedByName, .Subject, .Parent.FolderPath End With End Sub
Надеюсь, что ты поможешь
