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

Вопрос:

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

  1. пройдите через свое дерево MAPI Folders – из выбранной начальной точки
  2. идентифицировать соответствующие объекты (элементы почты… в папках могут быть и другие элементы)
  3. захватить некоторые данные о соответствующих объектах и записать их в 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

Надеюсь, что ты поможешь

Оцените статью
TechArks.Ru
Добавить комментарий