Копировать данные из электронных писем в Outlook Inbox и личных подпапок в Excel через VBA

Question

Мне нужно скопировать поля имени, темы и полученной даты из электронных писем, полученных в моих почтовых ящиках 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

Answer 1

Давайте немного разберем вашу задачу .... насколько я понимаю, вам нужно написать некоторый код, возможно, также пользовательскую форму для захвата точки входа в структуру вашей папки MAPI и, возможно, параметр даты (элементы послеD ...) в Outlook VBA.Тогда есть три основные части проблемы:

1. - пройтись по дереву папок MAPI - из выбранной отправной точки
2. определить соответствующие объекты (почтовые отправления ... могут быть другиеэлементы также в папках)
3. захватывает некоторые данные элементов соответствующих объектов и записывает их в Excel

ad 1 : это, скорее всего, будетрекурсивная задача - перейти к нижней части структуры папок с определенной начальной точки (корневой или любой папки, которую пользователь может выбрать).Поэтому я лично был бы осторожен с общими общими папками , поскольку они могли скрывать ОГРОМНОЕ количество папок / элементов и открывать всевозможные проблемы (чрезмерное время выполнения, ограничения доступа и т. Д.).Кроме того, вы, вероятно, не хотите захватывать почтовые элементы в папке «Удаленные» и ее подпрограммах.Также вы можете захотеть передать параметр DATE в такую ​​рекурсивную процедуру - введенную пользователем - для захвата элементов, созданных / отправленных после определенной даты.

вот блок кода, который вы можете использовать для заполнения объекта древовидного представления впользовательская форма, которая запрашивает корневую 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

ad 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

Надеюсь, что это поможет вам добиться успеха