通過Excel在共享郵箱中創建文件夾VBA

我正在使用下面的代碼來發現在Excel中從列表中創建Outlook中的電子郵件文件夾。我可以從我的默認電子郵件帳戶中正常工作，但我正在努力爲共享郵箱實施它。通過Excel在共享郵箱中創建文件夾VBA

我已添加代碼以返回與指定電子郵件地址關聯的帳號（如外部參照）。我如何修改'添加文件夾'部分以利用這些信息（並且我是否需要將代碼重置爲用戶默認的代碼？）。

然後，我還需要知道如何將現有的文件夾移動到另一個文件夾（例如，從'DEV TEST'到'DEV TEST/ARCHIVE'）。

感謝。

Sub CreateEmailFol() 

Dim admin As Worksheet 

Set admin = ThisWorkbook.Worksheets("Admin") 

Const olFolderInbox As Long = 6 
Dim OutlApp As Object 
Dim a(), x 
Dim IsCreated As Boolean 

Dim OutApp As Outlook.Application 
Dim i As Long 

    ' Get account number for email address 
    Set OutApp = CreateObject("Outlook.Application") 

    For i = 1 To OutApp.Session.Accounts.Count 
     If OutApp.Session.Accounts.Item(i) = "[email protected]" Then xref = i 
    Next i 

    ' Copy folder names into array to speed up the code 
    With admin 
     If .FilterMode Then .ShowAllData 
     a = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Offset(1, 0).Value 
     If Not IsArray(a) Then x = a: ReDim a(1 To 1): a(1) = x 
    End With 

    ' Use already open Outlook application if possible 
    On Error Resume Next 
    Set OutlApp = GetObject(, "Outlook.Application") 
    If Err Then 
     Set OutlApp = CreateObject("Outlook.Application") 
     IsCreated = True 
    End If 

    ' Add folders 
    With OutlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("DEV TEST") 
     For Each x In a 
     .Folders.Add x 
     Next 
    End With 

    ' Release the memory of object variable 
    Set OutlApp = Nothing 
    Set OutApp = Nothing 

End Sub

來源

2016-05-24 PaulyB

您需要調用NameSpace.GetSharedDefaultFolder才能訪問用戶的共享收件箱。但是，除非該用戶授予您完整郵箱權限，並且您將該郵箱添加爲Outlook配置文件中的其他帳戶（然後您可以通過該帳戶訪問該子文件夾），否則您將無法訪問任何其他郵件文件夾（例如，收件箱下的子文件夾）商店收藏）。

來源

2016-05-24 20:02:10

通過Excel在共享郵箱中創建文件夾VBA

回答

相關問題