VBA для переноса электронной почты из приложения Outlook в Excel
Мне нужна ваша помощь, ребята, если вы можете. Я новичок в VBA, поэтому все еще учусь, и мой код, вероятно, не очень мощный, но я хотел бы воплотить его в жизнь. Это работает, но не так, как я ожидал. Я делюсь с вами своим кодом Excel VBA для получения электронной почты из Outlook. Когда я запускаю Excel и Outlook и запускаю код vba, я получаю ошибку в этой строке =>
Set Folder = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName)
но когда я закрываю и снова открываю Outlook, он работает и помещает всю информацию в таблицу до 30 дней назад, а затем я получаю сообщение «объект не поддерживает этот метод свойства» code438.. в этой строке =>
Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime
К вашему сведению... У меня есть адрес электронной почты по умолчанию, настроенный в Outlook, который принадлежит мне, и общий адрес электронной почты, который также используют другие люди, и в общем адресе электронной почты есть подфайл. поэтому я пытаюсь получить электронное письмо только с общего адреса электронной почты и подпапки.
Вот код:
Sub GetEmailsInTo()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim Pst_Folder_Name As String
Dim MailboxName As String
Dim subFolderName As String
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailboxName = "[email protected]"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox"
'subfolder name
subFolderName = "important"
Set Folder = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName)
If Folder = "" Then
MsgBox "Invalid Data in Input"
GoTo end_lbl1:
End If
Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear
'Date
Columns("A:A").Select
Selection.NumberFormat = "[$-409]ddd dd/mm/yy;@"
Range("A2:A500").Select
Selection.ColumnWidth = 13
Range("A2:A500").HorizontalAlignment = xlLeft
Range("A2:A500").VerticalAlignment = xlCenter
Range("A1:E1").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.RowHeight = 55
.HorizontalAlignment = xlCenter
End With
Range("B2:B500").Select
With Selection
.WrapText = True
.ColumnWidth = 16
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Range("C2:C500").Select
With Selection
.WrapText = True
.ColumnWidth = 40
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Range("D2:D500").Select
With Selection
.WrapText = True
.ColumnWidth = 170
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
Range("E2:E500").Select
With Selection
.WrapText = True
.ColumnWidth = 50
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
'Rad Through each Mail and export the details to Excel for Email Archival
Sheets(1).Activate
For iRow = 2 To Folder.Items.Count
Sheets(1).Cells(iRow, 2).Select
Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime
Sheets(1).Cells(iRow, 2) = Folder.Items.Item(iRow).SenderName
Sheets(1).Cells(iRow, 3) = Folder.Items.Item(iRow).Subject
Sheets(1).Cells(iRow, 4) = Folder.Items.Item(iRow).To
Sheets(1).Cells(iRow, 5) = Folder.Items.Item(iRow).CC
Next iRow
MsgBox "Email import complete"
end_lbl1:
End Sub
если я поменяю его на ns.Fol... то будет то же самое. работает и получает все электронные письма, но показывает ошибку в строке Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime и выдает мне ошибку. следует просто сказать MsgBox «Импорт электронной почты завершен».
Отредактируйте сообщение, добавив первую ошибку.
Разбейте Set Folder на три части, чтобы увидеть, где возникает первая ошибка.
@niton, если я запускаю код без этой части => Set Folder = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName) и запускаю первый как Set Folder = Outlook.Session.Folders( MailboxName) работает без ошибок, когда я пытаюсь запустить файл входящих сообщений и подфайл, получая ошибку в коде => Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime
Ожидается один вопрос на пост. Вы можете задать новый вопрос о папке. Set Folder = ns.Folders(MailboxName) и Set Folder = Folder.Folders(Pst_Folder_Name) и Set Folder = Folder.Folders(subFolderName). Укажите ошибку и в какой строке она возникает.
Ответы 2
Ваш код работает для почты. Проблема может заключаться в том, что в папке есть элементы, которые не являются письмами. Отфильтруйте это примерно так:
iRow=2
For iRowAct = 1 To Folder.Items.Count
If Folder.Items.Item(iRowAct).Class = olMail Then
Sheets(1).Cells(iRow, 2).Select
Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRowAct).ReceivedTime
Sheets(1).Cells(iRow, 2) = Folder.Items.Item(iRowAct).SenderName
Sheets(1).Cells(iRow, 3) = Folder.Items.Item(iRowAct).Subject
Sheets(1).Cells(iRow, 4) = Folder.Items.Item(iRowAct).To
Sheets(1).Cells(iRow, 5) = Folder.Items.Item(iRowAct).CC
iRow = iRow + 1
End If
Next iRowAct
Если Folder.Items.item(iRow).Class = olMail Тогда => ошибка => индекс массива выходит за пределы
@miki Аааа. Пожалуйста. см. редактирование.
Прошу прощения за задержку, меня не было... все работает великолепно @Black cat. Большое спасибо за обновление кода для меня. +++++
Не-mailitem может не иметь свойства mailitem. Кроме того, iRow на один больше, чем индекс элемента.
Option Explicit
Sub GetEmailsInToV2()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim mailboxFolder As Outlook.folder
Dim inboxFolder As Outlook.folder
Dim subFolder As Outlook.folder
Dim mailboxName As String
Dim inboxName As String
Dim subFolderName As String
Dim iRow As Long
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
'Mailbox Name as displayed in your Outlook Session)
mailboxName = "[email protected]"
inboxName = "Inbox"
'subfolder name
subFolderName = "important"
' No attempt to address unknown error referencing the subfolder
Set mailboxFolder = ns.Folders(mailboxName)
Set inboxFolder = mailboxFolder.Folders(inboxName)
Set subFolder = inboxFolder.Folders(subFolderName)
Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear
'Date
With Columns("A:A")
.NumberFormat = "[$-409]ddd dd/mm/yy;@"
.ColumnWidth = 13
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("B:B")
.WrapText = True
.ColumnWidth = 16
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("C:C")
.WrapText = True
.ColumnWidth = 40
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("D:D")
.WrapText = True
.ColumnWidth = 170
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
With Range("E:E")
.WrapText = True
.ColumnWidth = 50
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
With Range("A1:E1")
.VerticalAlignment = xlBottom
.WrapText = False
.RowHeight = 55
.HorizontalAlignment = xlCenter
End With
'Read each mail and export the details to Excel for Email Archival
'Sheets(1).Activate
For iRow = 2 To subFolder.Items.Count + 1
With subFolder.Items.Item(iRow - 1)
' Non-mailitems may not have mailitem properties
If .Class = olMail Then
'Sheets(1).Cells(iRow, 2).Select
Sheets(1).Cells(iRow, 1) = .ReceivedTime
Sheets(1).Cells(iRow, 2) = .SenderName
Sheets(1).Cells(iRow, 3) = .Subject
Sheets(1).Cells(iRow, 4) = .To
Sheets(1).Cells(iRow, 5) = .CC
' Clear requires an entry in column E
If Sheets(1).Cells(iRow, 5) = "" Then
Sheets(1).Cells(iRow, 5) = "-"
End If
Else
Sheets(1).Cells(iRow, 1) = "-" ' Clear requires an entry in column A
Sheets(1).Cells(iRow, 3) = "Not a mailitem."
Sheets(1).Cells(iRow, 5) = "-" ' Clear requires an entry in column E
End If
End With
Next
MsgBox "Email import complete"
End Sub
Спасибо за вашу помощь. Этот код работает так, что импорт сообщения завершен, но список пуст. С некоторыми небольшими изменениями этот код будет работать для меня, но я уже нашел решения, которые работают для меня от пользователя «Черный кот». В любом случае спасибо.
Попробуйте
Set Folder = ns.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName)