我有以下宏,用于从Outlook导入电子邮件。宏仅从“收件箱”文件夹
导入电子邮件我希望宏通过收件箱文件夹的subfolders
(因此,没有已发送的邮件等,但仅收件箱文件夹的sub folders
)。
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem
Application.ScreenUpdating = False
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set olShareName = OutlookNamespace.CreateRecipient("shared_mailbox_name")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
Range("A:I").ClearContents
Range("A3").Value = "Subject"
Range("B3").Value = "Date"
Range("C3").Value = "Sender"
Range("D3").Value = "Category"
Range("E3").Value = "Mailbox"
i = 4
On Error Resume Next
For Each OutlookMail In Folder.Items
Range("A" & i).Value = OutlookMail.Subject
Range("B" & i).Value = OutlookMail.ReceivedTime
Range("C" & i).Value = OutlookMail.SenderName
Range("D" & i).Value = OutlookMail.Categories
Range("E" & i).Value = OutlookMail.Folder
在“ E”列中,我想写一封用于接收电子邮件的文件夹的名称...
所以其他列已经可以了,但是这样,我想如果它是从Inbox文件夹复制的,那么它将在E column
中写入Inbox,但是如果它是从Subfolder1
复制的然后它将写入SUbfolder1
等等...
我应该如何处理?
答案 0 :(得分:1)
尝试以下
Option Explicit
Private Sub Example()
Dim olApp As outlook.Application
Set olApp = New outlook.Application
Dim olNs As outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim olRecip As outlook.Recipient
Set olRecip = olNs.CreateRecipient("0m3r@EmailAddress.com") ' Update email
Dim Inbox As outlook.MAPIFolder
Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Sheets("Sheet1")
With Sht
.Range("A3").Value = "Subject"
.Range("B3").Value = "Date"
.Range("C3").Value = "Sender"
.Range("D3").Value = "Category"
.Range("E3").Value = "Mailbox"
End With
' // Process Current Folder
LoopFolders Inbox, Sht
End Sub
Private Sub LoopFolders( _
ByVal CurrentFolder As outlook.MAPIFolder, _
ByVal Sht As Worksheet _
)
Dim Items As outlook.Items
Set Items = CurrentFolder.Items
Dim i As Long
Dim last_row As Long
Dim Item As Object ' Outlook.MailItem
With Sht
last_row = Sht.Range("A" & .Rows.Count).End(xlUp).Row + 1
For i = Items.Count To 1 Step -1 ' run loop
Set Item = Items(i)
DoEvents
If TypeOf Item Is outlook.MailItem Then
Debug.Print Item
.Range("A" & last_row).Value = Item.Subject
.Range("B" & last_row).Value = Item.ReceivedTime
.Range("C" & last_row).Value = Item.SenderName
.Range("D" & last_row).Value = Item.Categories
.Range("E" & last_row).Value = CurrentFolder.Name
End If
last_row = last_row + 1
Next
' // Recurse through subfolders
Dim folder As outlook.MAPIFolder
If CurrentFolder.Folders.Count > 0 Then
For Each folder In CurrentFolder.Folders
LoopFolders folder, Sht
Next
End If
End With
' // Cleanup
Set folder = Nothing
Set Item = Nothing
Set Items = Nothing
End Sub