Question

我正在尝试在Outlook 2003中编写VBA代码，这将在发送时向电子邮件添加类别，以便响应将显示自动添加的类别。这是为了使归档响应更容易。

例如，如果我发送回复所有人的电子邮件，我的收件箱中的回复最好会自动显示为“〜回复”类别。目前所有回复我都是手动分类的。

任何人都可以协助使用此代码吗？我已经看到如何从此论坛中删除类别，但我正在尝试添加一个。

Answer 1

我无法使用共享收件箱对此进行测试，但我希望以下内容有所帮助。

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模块中。

打开Outlook时会调用第一个例程（Application_Startup）。

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。这允许我为添加到收件箱的新项目指定事件处理程序。

在单击Send buttom之后和发送消息之前调用下一个例程（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

希望上面给出了一些想法。

使用VBA为传入电子邮件添加类别

1 个答案: