☰

在共享邮箱 Outlook 365 上运行 VBA

tag-icon • tag-icon email microsoft-outlook vba attachments shared-mailbox
在共享邮箱 Outlook 365 上运行 VBA

我有此代码，用于将特定发件人和主题的电子邮件附件保存到我的硬盘上。当它仅在我的个人邮箱上工作时，它工作正常。但我需要它与我与同事共享的邮箱一起工作。

我在“ThisOutlookSession”中有此代码：

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
 Dim objNS As NameSpace
 Set objNS = Application.Session

 Set olInboxItems = GetFolderPath("name of the shared mailbox\Inbox").Items
 Set objNS = Nothing
End Sub


Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
    Set Msg = item

    'Change variables to match need. Comment or delete any part unnecessary.
    If (Msg.SenderName = "Sender name") And _
        (Msg.Subject = "test") And _
        (Msg.Attachments.Count >= 1) Then

        'Set folder to save in.
        Dim olDestFldr As Outlook.MAPIFolder
        Dim myAttachments As Outlook.Attachments
        Dim Att As String

        'location to save in.  Can be root drive or mapped network drive.
        Const attPath As String = "U:\TESTING\"

        ' save attachment
        Set myAttachments = item.Attachments
        Att = myAttachments.item(1).DisplayName
        myAttachments.item(1).SaveAsFile attPath & Att

        ' mark as read
        Msg.UnRead = False
    End If

End If

ProgramExit:
 Exit Sub
ErrorHandler:
 MsgBox Err.Number & " - " & Err.Description
 Resume ProgramExit
End Sub

然后我的模块中有这个 GetFolderPath 函数：

' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
 Dim oFolder As Outlook.Folder
 Dim FoldersArray As Variant
 Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
    FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.item(FoldersArray(0))
If Not oFolder Is Nothing Then
    For i = 1 To UBound(FoldersArray, 1)
        Dim SubFolders As Outlook.Folders
        Set SubFolders = oFolder.Folders
        Set oFolder = SubFolders.item(FoldersArray(i))
        If oFolder Is Nothing Then
            Set GetFolderPath = Nothing
        End If
    Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
 Set GetFolderPath = Nothing
 Exit Function
End Function

你对它为什么不起作用有什么建议吗？非常感谢

答案1

它不起作用的原因是您需要将共享邮箱添加为第二个帐户。只有这样，VBA 才能找到邮箱并使用它。

您只需提供电子邮件地址和虚假密码即可添加邮箱。出现登录提示后，输入您自己的电子邮件地址/用户名和密码，它将被添加为第二个邮件地址。

请注意，您必须关闭 Outlook 并重新打开它（可能要两次）才能将两个帐户合并为一个帐户。否则您将看到两次。

答案2

我不确定这是否仍是人们所疑问的问题，但我有答案。

https://docs.microsoft.com/en-us/office/vba/outlook/concepts/electronic-business-cards/using-events-with-automation

当使用这样的事件处理程序时，它需要是一个类对象。

例如在 ClassModuleName 类中：

Public WithEvents EventHandler As Items 'note the public it is required

Private Sub EventHandler_ItemAdd(ByVal item As Object) 'note the change in name.

On Error GoTo ErrorHandler

'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
    Set Msg = item

    'Change variables to match need. Comment or delete any part unnecessary.
    If (Msg.SenderName = "Sender name") And _
        (Msg.Subject = "test") And _
        (Msg.Attachments.Count >= 1) Then

        'Set folder to save in.
        Dim olDestFldr As Outlook.MAPIFolder
        Dim myAttachments As Outlook.Attachments
        Dim Att As String

        'location to save in.  Can be root drive or mapped network drive.
        Const attPath As String = "U:\TESTING\"

        ' save attachment
        Set myAttachments = item.Attachments
        Att = myAttachments.item(1).DisplayName
        myAttachments.item(1).SaveAsFile attPath & Att

        ' mark as read
        Msg.UnRead = False
    End If

End If

ProgramExit:
 Exit Sub
ErrorHandler:
 MsgBox Err.Number & " - " & Err.Description
 Resume ProgramExit
End Sub

那么在您的实际会话中它将是：


    Dim AnyName as New ClassModuleName

    Private Sub Application_Startup()
        Dim objNS As NameSpace
        Set objNS = Application.Session
        Set AnyName= GetFolderPath("name of the shared mailbox\Inbox").Items
        Set objNS = Nothing
    End Sub

这会将处理程序初始化为一个新对象，并将其分配给所需的文件夹，同时为其提供事件选项“addItem”

答案3

如果Set olInboxItems = GetFolderPath("name of the shared mailbox\Inbox").Items

然后Private Sub olInboxItems_ItemAdd(ByVal item As Object)

相关内容