如何使用VBA从共享邮箱发送Outlook会议邀请？

问题背景 #

使用VBA创建会议邀请时，个人邮箱环境下代码可正常运行，但切换到已拥有全部权限的共享邮箱时无法生效，推测问题出在OutAccount的设置逻辑上。

原代码 #

Sub send_invites(r As Long)
    Dim OutApp As Outlook.Application
    Dim OutMeet As Outlook.AppointmentItem
    Set OutApp = Outlook.Application
    Set OutMeet = OutApp.CreateItem(olAppointmentItem)
    Dim OutAccount As Outlook.Account: Set OutAccount = OutApp.Session.Accounts.Item(1)

    With OutMeet
        .Subject = Cells(r, 1).Value
        .RequiredAttendees = Cells(r, 11).Value
        ' .OptionalAttendees = ""
    
        Dim sDate As Date: sDate = Cells(r, 2).Value + Cells(r, 3).Value
        Dim eDate As Date: eDate = Cells(r, 4).Value + Cells(r, 5).Value
            
        .Start = sDate
        .End = eDate
            
        .Importance = olImportanceHigh
            
        Dim rDate As Date: rDate = Cells(r, 7).Value + Cells(r, 8).Value
        Dim minBstart As Long: minBstart = DateDiff("n", sDate, eDate)
            
        .ReminderMinutesBeforeStart = minBstart
            
        .Categories = Cells(r, 9)
        .Body = Cells(r, 10)
            
        .MeetingStatus = olMeeting
        .Location = "Microsoft Teams"
            
        .SendUsingAccount = OutAccount
        .Send
    End With
    
    Set OutApp = Nothing
    Set OutMeet = Nothing
End Sub

Sub send_invites_click()
    Dim rg As Range: Set rg = shData.Range("A1").CurrentRegion
    Dim i As Long
    For i = 2 To rg.Rows.Count
        Call send_invites(i)
    Next i
End Sub

问题分析 #

原代码中OutApp.Session.Accounts.Item(1)直接取第一个账号，这通常是你的个人邮箱账号，而非目标共享邮箱账号，导致会议邀请仍从个人邮箱发出，无法关联到共享邮箱。

解决方案 #

修改共享邮箱账号的获取逻辑，通过遍历Accounts集合，匹配共享邮箱的SMTP地址或显示名称来定位目标账号。若需要将会议保存到共享邮箱日历，可添加.Move方法将会议移动到对应日历文件夹。

修改后的代码 #

Sub send_invites(r As Long)
    Dim OutApp As Outlook.Application
    Dim OutMeet As Outlook.AppointmentItem
    Dim OutAccount As Outlook.Account
    Dim sharedMailboxAddr As String
    Dim sharedCalendar As Outlook.Folder
    
    ' 替换为你的共享邮箱SMTP地址，例如 "shared@company.com"
    sharedMailboxAddr = "你的共享邮箱地址"
    
    Set OutApp = Outlook.Application
    
    ' 遍历Accounts集合，精准定位共享邮箱账号
    For Each OutAccount In OutApp.Session.Accounts
        If OutAccount.SmtpAddress = sharedMailboxAddr Then
            Exit For
        End If
    Next OutAccount
    
    ' 未找到账号时提示并退出
    If OutAccount Is Nothing Then
        MsgBox "未找到指定的共享邮箱账号", vbExclamation
        Exit Sub
    End If
    
    ' 创建会议邀请
    Set OutMeet = OutApp.CreateItem(olAppointmentItem)
    
    With OutMeet
        .Subject = Cells(r, 1).Value
        .RequiredAttendees = Cells(r, 11).Value
        ' .OptionalAttendees = ""
    
        Dim sDate As Date: sDate = Cells(r, 2).Value + Cells(r, 3).Value
        Dim eDate As Date: eDate = Cells(r, 4).Value + Cells(r, 5).Value
            
        .Start = sDate
        .End = eDate
            
        .Importance = olImportanceHigh
            
        Dim minBstart As Long: minBstart = DateDiff("n", sDate, eDate)
        .ReminderMinutesBeforeStart = minBstart
            
        .Categories = Cells(r, 9)
        .Body = Cells(r, 10)
            
        .MeetingStatus = olMeeting
        .Location = "Microsoft Teams"
            
        ' 设置发送账号为共享邮箱
        .SendUsingAccount = OutAccount
        
        ' 可选：将会议移动到共享邮箱的日历（需确保共享邮箱已添加到Outlook）
        Set sharedCalendar = OutApp.Session.Folders(sharedMailboxAddr).Folders("日历")
        .Move sharedCalendar
        
        .Send
    End With
    
    ' 释放对象
    Set OutApp = Nothing
    Set OutMeet = Nothing
    Set OutAccount = Nothing
    Set sharedCalendar = Nothing
End Sub

Sub send_invites_click()
    Dim rg As Range: Set rg = shData.Range("A1").CurrentRegion
    Dim i As Long
    For i = 2 To rg.Rows.Count
        Call send_invites(i)
    Next i
End Sub

注意事项 #

1. 务必将代码中的sharedMailboxAddr替换为实际的共享邮箱SMTP地址。
2. 若共享邮箱未在Outlook中显示，需先通过Outlook添加该共享邮箱（路径：文件→账户设置→账户设置→新建→输入共享邮箱地址）。
3. 若不需要将会议保存到共享邮箱日历，可删除.Move sharedCalendar相关代码。

内容的提问来源于stack exchange，提问作者Suman Razz