使用调用VBA脚本的规则保存电子邮件

Question

我正在尝试将某个地址收到的所有电子邮件保存到我的硬盘驱动器。我已经拼凑/编辑了以下代码，但它不适用于我的规则。当我手动运行规则时，它工作正常。当我手动运行代码时，它工作正常。但是，当我从我为其设置规则的地址发送测试电子邮件时，它不会保存电子邮件。

Public Sub SaveMessageAsMsg(itm As Outlook.MailItem)
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim SndName As String
  Dim enviro As String
  Dim ns As Outlook.NameSpace
  Dim iInbox As MAPIFolder
  enviro = "c:MyFolder" 'sets folder to save messgaes to

  Set ns = Application.GetNamespace("MAPI")
  Set iInbox = ns.GetDefaultFolder(olFolderInbox)
  For Each objItem In iInbox.Items
  'I've tried the below method and get the same results
    'For i = iInbox.Items.Count To 1 Step -1
    'Set objItem = iInbox.Items(i)
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
    sName = oMail.Subject
    SndName = oMail.SenderName
    dtDate = oMail.ReceivedTime
    ReplaceCharsForFileName sName, "-"
        sName = Right(sName, 100)
'formats the file name as "Sender name - Date - Time - Subject"
            sName = SndName & " - " & Format(dtDate, "mm-dd-yyyy",  vbUseSystemDayOfWeek, _
            vbUseSystem) & " - " & Format(dtDate, "hhnnss", _
            vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
    sPath = enviro
    Debug.Print sPath & sName
    oMail.saveas sPath & sName, olMsg
End If
Set objAtt = Nothing
Next
End Sub
  Private Sub ReplaceCharsForFileName(sName As String, _
    sChr As String _
  )
  'Replaces the invalid characters you could use RegX with vbscript instead
   sName = Replace(sName, "´", "'")
   sName = Replace(sName, "`", "'")
   sName = Replace(sName, "{", "(")
   sName = Replace(sName, "[", "(")
   sName = Replace(sName, "]", ")")
   sName = Replace(sName, "}", ")")
   sName = Replace(sName, "  ", " ")     'Replace two spaces with one space
   sName = Replace(sName, "   ", " ")    'Replace three spaces with one       space
   sName = Replace(sName, "    ", " ")   'Replace four spaces with one space
   sName = Replace(sName, "     ", " ")  'Replace five spaces with one space
   sName = Replace(sName, "      ", " ") 'Replace six spaces with one space
   'Cut out invalid signs.
   sName = Replace(sName, ": ", "_")     'Colan followded by a space
   sName = Replace(sName, ":", "_")      'Colan with no space
   sName = Replace(sName, "/", "_")
   sName = Replace(sName, "", "_")
   sName = Replace(sName, "*", "_")
   sName = Replace(sName, "?", "_")
   sName = Replace(sName, """", "'")
   sName = Replace(sName, "<", "_")
   sName = Replace(sName, ">", "_")
   sName = Replace(sName, "|", "_")
   sName = Replace(sName, "%", "pc")
   sName = Replace(sName, vbTab, " ")     'Replaces vbTab as this is  sometimes a delimiter if copied from excel
  End Sub

我相当确定问题出在第一行，但我不确定如何解决它。

Public Sub SaveMessageAsMsg(itm As Outlook.MailItem)

谢谢

Answer 1

未经测试：

Public Sub SaveMessageAsMsg(itm As Outlook.MailItem)
    Const ENVIRO As String = "c:MyFolder" 'sets folder to save messgaes to
    Dim dtDate As Date
    Dim sName As String
    Dim SndName As String
    If itm.MessageClass = "IPM.Note" Then
        sName = itm.Subject
        SndName = itm.SenderName
        dtDate = itm.ReceivedTime
        ReplaceCharsForFileName sName, "-"
        sName = Right(sName, 100)
        'formats the file name as "Sender name - Date - Time - Subject"
        sName = SndName & " - " & Format(dtDate, "mm-dd-yyyy", vbUseSystemDayOfWeek, _
                vbUseSystem) & " - " & Format(dtDate, "hhnnss", _
                vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
        Debug.Print ENVIRO & sName
        oMail.SaveAs ENVIRO & sName, olMsg
    End If
End Sub

Answer 2

最终代码：

Public Sub SaveMessageAsMsg(itm As Outlook.MailItem)
Const ENVIRO As String = "c:MyFolder" 'sets folder to save messages to
  Dim oMail As Outlook.MailItem
  Dim dtDate As Date
  Dim sName As String
  Dim SndName As String

 If itm.MessageClass = "IPM.Note" Then
Set oMail = itm
    sName = itm.Subject
    SndName = itm.SenderName
    dtDate = itm.ReceivedTime
    ReplaceCharsForFileName sName, "-"
    sName = Right(sName, 100)
    'formats the file name as "Sender name - Date - Time - Subject"
    sName = SndName & " - " & Format(dtDate, "mm-dd-yyyy",  vbUseSystemDayOfWeek, _
            vbUseSystem) & " - " & Format(dtDate, "hhnnss", _
            vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
    Debug.Print ENVIRO & sName
    oMail.saveas ENVIRO & sName, olMsg
  End If
  End Sub
  Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
'Replaces the invalid characters you could use RegX with vbscript instead
 sName = Replace(sName, "´", "'")
 sName = Replace(sName, "`", "'")
 sName = Replace(sName, "{", "(")
 sName = Replace(sName, "[", "(")
 sName = Replace(sName, "]", ")")
 sName = Replace(sName, "}", ")")
 sName = Replace(sName, "  ", " ")     'Replace two spaces with one space
 sName = Replace(sName, "   ", " ")    'Replace three spaces with one space
 sName = Replace(sName, "    ", " ")   'Replace four spaces with one space
 sName = Replace(sName, "     ", " ")  'Replace five spaces with one space
 sName = Replace(sName, "      ", " ") 'Replace six spaces with one space
 'Cut out invalid signs.
 sName = Replace(sName, ": ", "_")     'Colan followded by a space
 sName = Replace(sName, ":", "_")      'Colan with no space
 sName = Replace(sName, "/", "_")
 sName = Replace(sName, "", "_")
 sName = Replace(sName, "*", "_")
 sName = Replace(sName, "?", "_")
 sName = Replace(sName, """", "'")
 sName = Replace(sName, "<", "_")
 sName = Replace(sName, ">", "_")
 sName = Replace(sName, "|", "_")
 sName = Replace(sName, "%", "pc")
 sName = Replace(sName, vbTab, " ")     'Replaces vbTab as this is sometimes a delimiter if copied from excel
End Sub