Question

我正在使用以下代码，我发现从Excel中的列表中创建Outlook中的电子邮件文件夹。我可以通过我的默认电子邮件帐户使其工作正常，但我很难为共享邮箱实现它。

我添加了代码以返回与指定电子邮件地址关联的帐号（作为外部参照号）。如何修改“添加文件夹”部分以利用此信息（我是否需要代码将帐户“重置”回用户的默认值？）。

然后我还需要知道如何将现有文件夹移动到另一个文件夹（例如从'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) = "x@x.com" 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

Answer 1

您需要调用NameSpace.GetSharedDefaultFolder才能访问用户的共享收件箱。但是，您将无法访问任何其他邮件文件夹（例如，收件箱下的子文件夹），除非该用户授予您完整邮箱权限，并且您将该邮箱添加为Outlook配置文件中的附加帐户（然后您可以通过商店收藏）。

通过Excel VBA在共享邮箱中创建文件夹

1 个答案: