根据Excel列中的模式在Inbox下生成Outlook文件夹/子文件夹

Question

我在网上找到了代码https://www.slipstick.com/macros/Create%20subfolders%20at%20multiple%20levels.txt，在Outlook中批量创建文件夹和子文件夹，并运行它，一切正常。

我想把它转换成在共享邮箱中工作。

Option Explicit
Public Sub MoveSelectedMessages()
Dim objParentFolder As Outlook.Folder ' parent
Dim newFolderName 'As String
Dim strFilepath

Dim xlApp As Object 'Excel.Application
Dim xlWkb As Object ' As Workbook
Dim xlSht As Object ' As Worksheet
Dim rng As Object 'Range
Set xlApp = CreateObject("Excel.Application")

strFilepath = xlApp.GetOpenFilename
If strFilepath = False Then
xlApp.Quit
Set xlApp = Nothing
Exit Sub
End If

Set xlWkb = xlApp.Workbooks.Open(strFilepath)
Set xlSht = xlWkb.Worksheets(1)
Dim iRow As Integer

iRow = 2

'select starting parent
Dim parentname
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim olShareName As Outlook.Recipient
Dim olApp As Outlook.Application
Set objParentFolder = Application.ActiveExplorer.CurrentFolder
Set olApp = Nothing
Set Ns = Nothing
Set olShareName = Nothing
Set olApp = New Outlook.Application
Set Ns = olApp.GetNamespace("MAPI")
Set olShareName = Ns.CreateRecipient("[e-mail]") '/// Owner's email address
Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox)
While xlSht.Cells(iRow, 1) <> ""
parentname = xlSht.Cells(iRow, 1)
newFolderName = xlSht.Cells(iRow, 2)


If parentname = "Inbox" Then
Set objParentFolder = Folder
Else
Set objParentFolder = Folder.Folders(parentname)
End If
On Error Resume Next
Dim objNewFolder As Outlook.Folder
Set objNewFolder = objParentFolder.Folders(newFolderName)
If objNewFolder Is Nothing Then
Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If

iRow = iRow + 1
' make new folder the parent
' Set objParentFolder = objNewFolder

Set objNewFolder = Nothing
Wend

xlWkb.Close
xlApp.Quit
Set xlWkb = Nothing
Set xlApp = Nothing
Set objParentFolder = Nothing
End Sub

它要求你选择一个格式化的Excel文档，然后根据Excel文件创建文件夹/子文件夹。

它不会创建嵌套文件夹，它只是在根收件箱文件夹中创建它们。可能是Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox)将所有内容还原回根收件箱，而不是像在用户邮箱中那样嵌套它们。

文件夹名称文件夹子文件夹SubFolder01SubFolder01aSubFolder01aASubFolder01aBSubFolder01aCSubFolder01aDSubFolder01aE

Answer 1

似乎你只需要从代码中更改以下部分:

If parentName = "Inbox" Then
Set objParentFolder = Folder 
Else
Set objParentFolder = Folder.Folders(parentName)
End If

要检查文件夹是否正确存在，可以使用Folders属性。但如果该文件夹不存在，则会抛出异常/错误。要处理这种情况，您可以在代码中使用以下结构:

Dim objNewFolder As Outlook.Folder
On Error Resume Next
Set objNewFolder = objParentFolder.Folders(newFolderName)
If objNewFolder Is Nothing Then
Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If

Answer 2

我无法复制这里承诺的结果
https://www.slipstick.com/developer/code-samples/create-outlook-folders-list-folder-names/
https://www.slipstick.com/macros/Create%20subfolders%20at%20multiple%20levels.txt

这将为问题中的示例生成嵌套文件夹。
此外，后续条目"收件箱"标志一组新的嵌套文件夹的开始。

Option Explicit
Private Sub GenerateFoldersFromExcelColumns()
Dim objParentFolder As Folder
Dim parentName As String

Dim objInboxFolder As Folder

Dim objNewFolder As Folder
Dim newFolderName As String

Dim xlApp As Object ' Excel.Application
Dim xlWkb As Object ' Excel.Workbook
Dim xlSht As Object ' Excel.Worksheet

Dim filePath As Variant

Dim iRow As Long

Set xlApp = CreateObject("Excel.Application")

filePath = xlApp.GetOpenFilename
If filePath = False Then
xlApp.Quit
Set xlApp = Nothing
Exit Sub
End If

Set xlWkb = xlApp.Workbooks.Open(filePath)
Set xlSht = xlWkb.Worksheets(1)

iRow = 2

'select starting parent
Set objInboxFolder = Session.GetDefaultFolder(olFolderInbox)

' Dim olShareName As Recipient
'Shared email address
' Set olShareName = Session.CreateRecipient("[e-mail]") 
' Debug.Print "olShareName: " & olShareName
' Set objInboxFolder = Session.GetSharedDefaultFolder(olShareName, olFolderInbox)

While xlSht.Cells(iRow, 1) <> ""

parentName = xlSht.Cells(iRow, 1)
Debug.Print "parentname: " & parentName

newFolderName = xlSht.Cells(iRow, 2)
Debug.Print "newFolderName: " & newFolderName

If parentName = "Inbox" Then

Set objParentFolder = objInboxFolder

Debug.Print "parentname: " & parentName
Debug.Print "objParentFolder.name: " & objParentFolder.name
Debug.Print "newFolderName: " & newFolderName

' Alternative code to avoid On Error Resume Next
' Check if an Outlook folder exists; if not create it
'  https://stackoverflow.com/questions/53365384

On Error Resume Next
' Try to create the folder without verification
' Bypass error when folder exists
Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
On Error GoTo 0 ' As soon as possible after On Error Resume Next

Set objNewFolder = objParentFolder.Folders(newFolderName)
Debug.Print "objNewFolder.name: " & objNewFolder.name

' for debugging
'Set ActiveExplorer.CurrentFolder = objNewFolder

ElseIf parentName = objParentFolder.name Then

Debug.Print "parentname: " & parentName
Debug.Print "objParentFolder.name: " & objParentFolder.name
Debug.Print "newFolderName: " & newFolderName

On Error Resume Next
Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
On Error GoTo 0 ' As soon as possible after On Error Resume Next

Set objNewFolder = objParentFolder.Folders(newFolderName)
Debug.Print "objNewFolder.name: " & objNewFolder.name

' for debugging
'Set ActiveExplorer.CurrentFolder = objNewFolder

Else

Set objParentFolder = objParentFolder.Parent

Debug.Print "parentname: " & parentName
Debug.Print "objParentFolder.name: " & objParentFolder.name
Debug.Print "newFolderName: " & newFolderName

On Error Resume Next
Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
On Error GoTo 0 ' As soon as possible after On Error Resume Next

Set objNewFolder = objParentFolder.Folders(newFolderName)
Debug.Print "objNewFolder.name: " & objNewFolder.name

' for debugging
'Set ActiveExplorer.CurrentFolder = objNewFolder

End If

iRow = iRow + 1

' make new folder the parent
Set objParentFolder = objNewFolder
Debug.Print "objParentFolder.name: " & objParentFolder.name

' No purpose in this case
'  but is typical with On Error Resume Next logic
'  when there is a test for Nothing
'Set objNewFolder = Nothing

Wend
exitRoutine:
xlWkb.Close
xlApp.Quit

Set xlSht = Nothing
Set xlWkb = Nothing
Set xlApp = Nothing

Debug.Print "Done."

End Sub