Question

我有2个单独工作的代码（如果我删除一个并保留另一个）。

这是为了保存收到的消息。

Option Explicit
Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then

  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

  enviro = CStr(Environ("USERPROFILE"))

  sName = Item.Subject
  ReplaceCharsForFileName sName, "_"

  dtDate = Item.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

' use My Documents for older Windows.
    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  Item.SaveAs sPath & sName, olMSG

  End If

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

这是为了保存外发消息：

    Private WithEvents objSentItems As Items
    Private Sub Application_Startup()
    Dim objSent As Outlook.MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
    Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
    Set objNS = Nothing
    End Sub

    Private Sub objSentItems_ItemAdd(ByVal Item As Object)
      Dim sPath As String
      Dim dtDate As Date
      Dim sName As String
      Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))

      sName = Item.Subject
      ReplaceCharsForFileName sName, "-"

      dtDate = Item.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

        sPath = enviro & "\Documents\"
      Debug.Print sPath & sName
      Item.SaveAs sPath & sName, olMSG
    End Sub

    Private Sub ReplaceCharsForFileName(sName As String, _
      sChr As String _
    )
      sName = Replace(sName, "/", sChr)
      sName = Replace(sName, "\", sChr)
      sName = Replace(sName, ":", sChr)
      sName = Replace(sName, "?", sChr)
      sName = Replace(sName, Chr(34), sChr)
      sName = Replace(sName, "<", sChr)
      sName = Replace(sName, ">", sChr)
      sName = Replace(sName, "|", sChr)
    End Sub

如何组合这两个以便保存传入和传出的消息？当我尝试运行它时，它给了我一个错误，我不能有2个“私人机智”。我把它放在“ThisoutlookSession”中。

Answer 1

你能试试吗？

Option Explicit
Private WithEvents Items As Outlook.Items
Private WithEvents objSentItems As Items

Private Sub Application_Startup()
  Dim Ns As Outlook.Namespace
  Dim objSent As Outlook.MAPIFolder
  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
  Set objSentItems = NS.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then

  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

  enviro = CStr(Environ("USERPROFILE"))

  sName = Item.Subject
  ReplaceCharsForFileName sName, "_"

  dtDate = Item.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

' use My Documents for older Windows.
    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  Item.SaveAs sPath & sName, olMSG

  End If

End Sub
Private Sub objSentItems_ItemAdd(ByVal Item As Object)
      Dim sPath As String
      Dim dtDate As Date
      Dim sName As String
      Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))

      sName = Item.Subject
      ReplaceCharsForFileName sName, "-"

      dtDate = Item.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

        sPath = enviro & "\Documents\"
      Debug.Print sPath & sName
      Item.SaveAs sPath & sName, olMSG
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Answer 2

以下是解决方案：

Option Explicit
Private WithEvents Items As Outlook.Items
Private WithEvents objSentItems As Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace

  Dim objSent As Outlook.MAPIFolder


  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.GetDefaultFolder(olFolderInbox).Items



  Set objSentItems = Ns.GetDefaultFolder(olFolderSentMail).Items

End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then

  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

  enviro = CStr(Environ("USERPROFILE"))

  sName = Item.Subject
  ReplaceCharsForFileName sName, "_"

  dtDate = Item.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"


    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  Item.SaveAs sPath & sName, olMsg

  End If

End Sub
Private Sub objSentItems_ItemAdd(ByVal Item As Object)
      Dim sPath As String
      Dim dtDate As Date
      Dim sName As String
      Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))

      sName = Item.Subject
      ReplaceCharsForFileName sName, "-"

      dtDate = Item.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

        sPath = enviro & "\Documents\"
      Debug.Print sPath & sName
      Item.SaveAs sPath & sName, olMsg
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

自动将传入/传出消息保存到硬盘驱动器

2 个答案: