共享收件箱子文件夹在 VBA 中不可见
Shared Inbox Subfolder not visible within VBA
我有一个几天前有效的例程,但现在挂断了 Set SubFolder = oInbox.Folders("ProcessedForms")
。
在执行期间在即时窗格中选中收件箱时,收件箱有 0(零)个文件夹。 ?oInbox.Folders.Count
.
我检查了 Office 365 在线和我计算机上的 Outlook 应用程序,有一个名为 'ProcessedForms' 的子文件夹。
完整代码如下:
Private Sub ScrapeOutlook(fileName As String, subject As String)
Dim intFileNum As Integer
Dim SubFolder As Outlook.MAPIFolder
On Error GoTo ScrapeOutlookErr
'Get the inbox from Outlook
Set oApp = New Outlook.Application
Set NS = oApp.Session
Set objOwner = NS.CreateRecipient("main@mycompany.com")
objOwner.Resolve
If objOwner.Resolved Then
Set oInbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Application.ActiveExplorer.CurrentFolder = oInbox
End If
If Not TESTING Then Set SubFolder = oInbox.Folders("ProcessedForms")
'Filter the items from the inbox based on the sender
Set oRestrictItems = oInbox.Items.Restrict("[Subject] = '" & subject & "'")
intFileNum = FreeFile
Open fileName For Output As intFileNum
itemsScraped = 0
For Each oLatestItem In oRestrictItems
Print #intFileNum, Replace( _
Replace( _
Replace( _
Replace( _
Replace(oLatestItem.Body, ",", "%") _
, vbNewLine, ",") _
, vbTab, ",") _
, ", ,Sent from Mycompany <https://mycompany.com> ,", "") _
, ", ,", ",") & ",Time," & oLatestItem.SentOn
If Not TESTING Then oLatestItem.UnRead = False
'If Not TESTING Then oLatestItem.Move SubFolder
itemsScraped = itemsScraped + 1
Next oLatestItem
Close #intFileNum
ScrapeOutlookExit:
Exit Sub
ScrapeOutlookErr:
HandleError "NewCustomers.ScrapeOutlook()"
Resume ScrapeOutlookExit
Resume
End Sub
GetSharedDefaultFolder
缓存在主邮箱的 OST 文件中的文件夹不包含子文件夹。取消选中 Exchange 帐户属性中的“下载共享文件夹”复选框,或在配置文件中将父邮箱作为代理邮箱打开,以便所有文件夹在 Outlook 中可用和可见。
如果文件夹在导航窗格中可见,您可以尝试:
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub ScrapeOutlook(fileName As String, subject As String)
Dim mailBox As Folder
Dim oInbox As Folder
Dim subFolder As Folder
'No error handling during debugging.
Set mailBox = Session.Folders("main@mycompany.com")
Set oInbox = mailBox.Folders("Inbox")
Debug.Print oInbox.Folders.count
If oInbox.Folders.count > 0 Then
Set subFolder = oInbox.Folders("ProcessedForms")
Set ActiveExplorer.CurrentFolder = subFolder
Else
Debug.Print "No subfolders found."
End If
End Sub
Private Sub test_ScrapeOutlook()
ScrapeOutlook "dummyFilename", "dummySubject"
End Sub
我有一个几天前有效的例程,但现在挂断了 Set SubFolder = oInbox.Folders("ProcessedForms")
。
在执行期间在即时窗格中选中收件箱时,收件箱有 0(零)个文件夹。 ?oInbox.Folders.Count
.
我检查了 Office 365 在线和我计算机上的 Outlook 应用程序,有一个名为 'ProcessedForms' 的子文件夹。
完整代码如下:
Private Sub ScrapeOutlook(fileName As String, subject As String)
Dim intFileNum As Integer
Dim SubFolder As Outlook.MAPIFolder
On Error GoTo ScrapeOutlookErr
'Get the inbox from Outlook
Set oApp = New Outlook.Application
Set NS = oApp.Session
Set objOwner = NS.CreateRecipient("main@mycompany.com")
objOwner.Resolve
If objOwner.Resolved Then
Set oInbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Application.ActiveExplorer.CurrentFolder = oInbox
End If
If Not TESTING Then Set SubFolder = oInbox.Folders("ProcessedForms")
'Filter the items from the inbox based on the sender
Set oRestrictItems = oInbox.Items.Restrict("[Subject] = '" & subject & "'")
intFileNum = FreeFile
Open fileName For Output As intFileNum
itemsScraped = 0
For Each oLatestItem In oRestrictItems
Print #intFileNum, Replace( _
Replace( _
Replace( _
Replace( _
Replace(oLatestItem.Body, ",", "%") _
, vbNewLine, ",") _
, vbTab, ",") _
, ", ,Sent from Mycompany <https://mycompany.com> ,", "") _
, ", ,", ",") & ",Time," & oLatestItem.SentOn
If Not TESTING Then oLatestItem.UnRead = False
'If Not TESTING Then oLatestItem.Move SubFolder
itemsScraped = itemsScraped + 1
Next oLatestItem
Close #intFileNum
ScrapeOutlookExit:
Exit Sub
ScrapeOutlookErr:
HandleError "NewCustomers.ScrapeOutlook()"
Resume ScrapeOutlookExit
Resume
End Sub
GetSharedDefaultFolder
缓存在主邮箱的 OST 文件中的文件夹不包含子文件夹。取消选中 Exchange 帐户属性中的“下载共享文件夹”复选框,或在配置文件中将父邮箱作为代理邮箱打开,以便所有文件夹在 Outlook 中可用和可见。
如果文件夹在导航窗格中可见,您可以尝试:
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub ScrapeOutlook(fileName As String, subject As String)
Dim mailBox As Folder
Dim oInbox As Folder
Dim subFolder As Folder
'No error handling during debugging.
Set mailBox = Session.Folders("main@mycompany.com")
Set oInbox = mailBox.Folders("Inbox")
Debug.Print oInbox.Folders.count
If oInbox.Folders.count > 0 Then
Set subFolder = oInbox.Folders("ProcessedForms")
Set ActiveExplorer.CurrentFolder = subFolder
Else
Debug.Print "No subfolders found."
End If
End Sub
Private Sub test_ScrapeOutlook()
ScrapeOutlook "dummyFilename", "dummySubject"
End Sub