-1

我正在尝试在 Outlook 2003 中编写 VBA 代码，该代码将在发送时将类别添加到电子邮件中，以便回复显示时会自动添加类别。这是为了使提交回复更容易。

例如，如果我发送一封回复所有人的电子邮件，我收件箱中的回复理想情况下会自动显示为“~Reply”的类别。目前我正在手动分类的所有回复。

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

4

1 回答 1

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

第一个例程 ( 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

以上希望能给大家一些思路。

于 2012-02-20T22:26:53.727 回答