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

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

2 个答案: