Question

我正在处理将Outlook附件保存到共享驱动器的脚本。

目前，以下脚本已成功从我自己的收件箱中保存了附件，但现在我想从共享邮箱中保存特定subfolder的附件。

我将如何修改以下代码来实现这一目标？

Private WithEvents InboxItems As Outlook.Items
    Const attPath As String = "T:\London File3 Group\Client Reporting\Test\ABI Daily\"

    Private Sub Application_Startup()
    Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
    Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
    Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    Dim Msg             As Outlook.MailItem: Set Msg = Item
    Dim olDestFldr      As Outlook.MAPIFolder
    Dim myAttachments   As Outlook.Attachments
    Dim Filename        As String

    If Not TypeName(Msg) = "MailItem" Then Exit Sub
    If (Msg.Subject Like "*Trade*") Or (Msg.Subject Like "*Trades*") Or (Msg.Subject Like "*Article 59*") Or (Msg.Subject Like "*Val*") Or (Msg.Subject Like "*Valuation*") Or (Msg.Subject Like "*Trading*") Or (Msg.Subject Like "*St James*") Then

    Set myAttachments = Item.Attachments
       Filename = myAttachments.Item(1).DisplayName
        myAttachments.Item(1).SaveAsFile attPath & Filename
        Msg.UnRead = False
    End If
End Sub

Answer 1

使用GetSharedDefaultFolder Method，它返回一个MAPIFolder对象，该对象代表指定用户的指定默认文件夹。此方法用于委派方案中，其中一个用户已将另一用户的一个或多个默认文件夹委派给另一用户

示例

Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\ABI Daily\"

Private Sub Application_Startup()
    Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
    Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
    Dim ShrdRecip As Outlook.Recipient: Set ShrdRecip = objectNS.CreateRecipient("0m3r@email.com")

    Set InboxItems = GetSharedDefaultFolder(ShrdRecip, olFolderInbox).Items
End Sub

编辑

子文件夹示例

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim ShrdRecip As Outlook.Recipient
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set ShrdRecip = olNs.CreateRecipient("0m3r@email.com")
    Set Inbox = olNs.GetSharedDefaultFolder(ShrdRecip, olFolderInbox) _
                                                .Folders("FolderName")
    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        Debug.Print Item.Subject ' print on Immediate window
    End If
End Sub

如何在共享邮箱Outlook VBA中引用子文件夹

1 个答案: