我无法使用共享收件箱对此进行测试，但希望以下内容有所帮助。
VBA 编辑器的资源管理器将列出如下结构：
- Project 1 (VbaProject.OTM)
+ Microsoft Office Outlook Objects
+ Forms
+ Modules
点击Microsoft Office Outlook Objects的+号获取
- Project 1 (VbaProject.OTM)
- Microsoft Office Outlook Objects
+ ThisOutlookSession
+ Forms
+ Modules
以下所有代码必须放在ThisOutlookSession模块中。
第一个例程 (Application_Startup) 在您打开 Outlook 时被调用。
Option Explicit
Public UserName As String
Public WithEvents MyNewItems As Outlook.Items
Private Sub Application_Startup()
' This event procedure is called when Outlook is started
Dim NS As NameSpace
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
With NS
UserName = .CurrentUser
Set MyNewItems = NS.GetDefaultFolder(olFolderInbox).Items
End With
MsgBox "Welcome " & UserName
End Sub
以上代码中有两个独立的活动。
首先它设置UserName = .CurrentUser。当我运行上面的代码时，UserName 被设置为我的用户名。我假设您和您的同事也是如此，因此下面的宏可以知道哪个用户是当前用户。请注意，用户必须授予宏访问.CurrentUser 的权限。您可能更喜欢使用 InputBox 来获取用户的姓名首字母。
其次，它初始化MyNewItems。这允许我为添加到收件箱的新项目指定一个事件处理程序。
下一个例程 (Application_ItemSend) 在单击发送按钮之后和发送消息之前调用。您可以更改或添加到消息中。您甚至可以使用Cancel = False 取消发送。
我已使用此例程将可能有用的属性输出到即时窗口。
根据我的实验，您设置的任何类别都会记录在“已发送邮件”版本中，但不会记录在发送给收件人的版本中。因此，即使对方使用 Outlook，他们也无法在回复中。
一种选择是在主题末尾添加一个代码。另一种选择是将.ReplyRecipients 设置为不同的地址。消息仍会从群组收件箱发送，但任何回复都会发送至.ReplyRecipients。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' This event procedure is called when the Send button is clicked but
' before the item is sent.
Dim Inx As Long
Debug.Print "------Item Send"
' Note this routine operate on all items not just mail items.
' See "myNewItems_ItemAdd" for a method of restricting the
' routine to mail items
With Item
.Subject = .Subject & " (xyz1)"
Debug.Print "Subject " & .Subject
For Inx = 1 To .Recipients.Count
Debug.Print "Recipient " & .Recipients(Inx).Name
Next
' Remove any existing reply recipients
Do While .ReplyRecipients.Count > 0
.ReplyRecipients.Remove 1
Loop
.ReplyRecipients.Add "JohnSmith@Company.com"
End With
End Sub
最后一个例程 (myNewItems_ItemAdd) 处理新邮件项目。当前代码不执行其他项目，例如会议请求。这段代码除了将主题输出到即时窗口之外什么都不做。但是，您可能希望将邮件移动到另一个文件夹。
Private Sub myNewItems_ItemAdd(ByVal Item As Object)
' This event procedure is called whenever a new item is added to
' to the InBox.
Dim NewMailItem As MailItem
Debug.Print "------Item Received"
On Error Resume Next
' This will give an error and fail to set NewMailIten if
' Item is not a MailItem.
Set NewMailItem = Item
On Error GoTo 0
If Not NewMailItem Is Nothing Then
' This item is a mail item
With NewMailItem
Debug.Print .Subject
End With
Else
' Probably a meeting request.
Debug.Print "Not mail item " & Item.Subject
End If
End Sub
希望以上内容能给你一些想法。