Мне нужна ваша помощь, ребята, если вы можете. Я новичок в 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
Ваш код работает для почты. Проблема может заключаться в том, что в папке есть элементы, которые не являются письмами. Отфильтруйте это примерно так:
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
Не-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