Outlook 2010 VBA Save Message as MSG Will Not Work as Script

问题

I am trying to get a script inside an Outlook rule to automatically save e-mail messages to a file server when they are received from a certain user/domain.

I found the following VBA Script on this site and it works if I manually run it, but it will not work inside my Outlook rule that says to use a script.

Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

  dtDate = oMail.ReceivedTime
  sName = sName & ".msg"

    sPath = enviro & "\Desktop\Allied E-File\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG

  End If
  Next

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

回答1:

but it will not work inside my Outlook rule that says to use a script

The argument must be type MailItem for the subroutine to be available in the Rules Wizard in Outlook to work

Example

Public Sub SaveMessageAsMsg(oMail As Outlook.MailItem)

     'Your code here

End Sub

Edit

Tested on Outlook 2010

Option Explicit
Sub SaveMessageAsMsg(Item As Outlook.MailItem)
    Dim objItem 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 = sName & ".msg"

    sPath = Enviro & "\Desktop\Allied E-File\"
        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

See here how to create rule

来源：https://stackoverflow.com/questions/31599483/outlook-2010-vba-save-message-as-msg-will-not-work-as-script

标签

vba

outlook