Saving Emails with Rule Calling VBA Script

Question

I'm trying to save all emails received by a certain address to my hard drive. I've pieced together / edited the following code but it will not work with my rule. When I run the rule manually it works fine. When I run the code manually it works fine. But when I send a test email from the address I have the rule set for it will not save the email.

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

I'm fairly certain the issue lies with this first line, but I'm not sure how to fix it.

Public Sub SaveMessageAsMsg(itm As Outlook.MailItem)

Thank you

Tim Williams · Accepted Answer

Untested:

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

Saving Emails with Rule Calling VBA Script

Answers (2)

Related Questions