macro to process incoming email (in inbox) in outlook, if subject matches crteria save to a file and delete


I would like an outlook macro to process incoming mail for the inbox.
if the subject contains "P:" then save it to a file with attachments and delete it.

Alternatively, I have a macro below that scans the inbox every 5 seconds, but will not delete , can you please fix

 Option Explicit
  Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub SaveAllEmails_ProcessAllSubFolders()
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrSavePath     As String
    Dim StrFolder       As String
    Dim StrFolderPath   As String
    Dim StrSaveFolder   As String
    Dim Prompt          As String
    Dim Title           As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As mailitem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
    ' ChosenFolder = "Inbox"
    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    StrSavePath = BrowseForFolder
    If StrSavePath = "" Then
GoTo ExitSub:
    End If
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, "\") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        If Not FSO.FolderExists(StrFolderPath) Then
            FSO.CreateFolder (StrFolderPath)
        End If
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
            StrReceived = ArrangedDate(mItem.ReceivedTime)
            StrSubject = mItem.Subject
            Debug.Print StrSubject
            If InStr(1, UCase(StrSubject), "P:") > 0 Or InStr(1, UCase(StrSubject), "T:") > 0 Then
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3

            mItem.Delete                 '  my code to try to delete
            End If
        Next j
        On Error GoTo 0
    Next i

Sleep (5000)

GoTo looper
End Sub
Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    StripIllegalChar = RegX.Replace(StrInput, "")
    Set RegX = Nothing
End Function
Function ArrangedDate(StrDateInput)
    Dim StrFullDate     As String
    Dim StrFullTime     As String
    Dim StrAMPM         As String
    Dim StrTime         As String
    Dim StrYear         As String
    Dim StrMonthDay     As String
    Dim StrMonth        As String
    Dim StrDay          As String
    Dim StrDate         As String
    Dim StrDateTime     As String
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    If Not Left(StrDateInput, 2) = "10" And _
    Not Left(StrDateInput, 2) = "11" And _
    Not Left(StrDateInput, 2) = "12" Then
        StrDateInput = "0" & StrDateInput
    End If
    StrFullDate = Left(StrDateInput, 10)
    If Right(StrFullDate, 1) = " " Then
        StrFullDate = Left(StrDateInput, 9)
    End If
    StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
    If Len(StrFullTime) = 10 Then
        StrFullTime = "0" & StrFullTime
    End If
    StrAMPM = Right(StrFullTime, 2)
    StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
    StrYear = Right(StrFullDate, 4)
    StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
    StrMonth = Left(StrMonthDay, 2)
    StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
    If Len(StrDay) = 1 Then
        StrDay = "0" & StrDay
    End If
    StrDate = StrYear & "-" & StrMonth & "-" & StrDay
    StrDateTime = StrDate & "_" & StrTime
    RegX.Pattern = "[\:\/\ ]"
    RegX.IgnoreCase = True
    RegX.Global = True
    ArrangedDate = RegX.Replace(StrDateTime, "-")
    Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    ''''''''''EntryID.Remove Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
    Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
    Set ShellApp = Nothing
End Function
'How to use:
'Open Outlook
'Open the VBE (Alt + F11)
'From the VBE top menu: Insert | Module
'Paste all of the code in the module that was created
'Close the VBE
'From the Outlook top menu: Tools | Macro | Macros...
'Select SaveAllEmails_ProcessAllSubFolders and click Run
'Test the code:
'After starting the macro you will be prompted for the Outlook folder to process and the local folder to save the files to.
'Note this if you have a lot of emails, this will take a while to run.

Who is Participating?
Chris BottomleySoftware Quality Lead EngineerCommented:
Seems to me that running a cyclic process is wasteful so ideally process on receipt per your request makes sense.  To put it together:

if the subject contains "P:" then save it to a file with attachments and delete it.

Save it as a .msg file
save all the attachments.

Save where i.e. attachments and msg in the same folder.
What to do with duplicated file names, replace or add a suffix of some kind?

Chris BottomleySoftware Quality Lead EngineerCommented:
Gone on and made my assumptions ... all files are saved with a numeric suffix for the 'version'.

A constant:
Const strSaveFolder As String = "c:\deleteme\"

is defined for all output files simply edit to your folder.

To use it ... place the code in a folder then ...

Create a rule that is triggered on all received mails and checks the subject for p: ... if found then run a script and you should see the inserted sub pColon.   Simply select it and it should be triggered on each received mail.

Sub pColon(mai As MailItem)
Dim strFileName As String
Dim ver As Long
Dim fso As Object
Dim att As Attachment
Dim fn As String
Dim ft As String
Const strSaveFolder As String = "c:\deleteme\"

    Set fso = CreateObject("scripting.filesystemobject")
    ver = 1
    strFileName = cleanFileName(mai.Subject)
    Do While fso.FileExists(strSaveFolder & strFileName & "_" & ver & ".msg")
        ver = ver + 1
    mai.SaveAs strSaveFolder & strFileName & "_" & ver & ".msg", olMSG
    For Each att In mai.Attachments
        If InStr(att.FileName, ".") > 0 Then
            ver = 1
            fn = Left(att.FileName, InStr(att.FileName, ".") - 1)
            ft = Right(att.FileName, Len(att.FileName) - InStr(att.FileName, ".") + 1)
            Do While fso.FileExists(strSaveFolder & fn & "_" & ver & ft)
                ver = ver + 1
            mai.SaveAs strSaveFolder & fn & "_" & ver & ft
        End If
    Set fso = Nothing
End Sub

Function cleanFileName(strFileName)
Dim strNew As String

    With CreateObject("vbscript.regexp")
        .IgnoreCase = True
        .Global = True
        .Pattern = "[(?*"",\\<>&#~%{}+_.@:\/!;]+"
        strNew = .Replace(strFileName, "_")
    End With
    cleanFileName = strNew

End Function

Open in new window

jbmsystemsAuthor Commented:
Give that man 500 points and a cigar
jbmsystemsAuthor Commented:

Is it possible to do the same thing in a compiled external module where we have to check many complex rules to parse the subject?  We have c# and   We also want to call a document management storage module.

Thanks again,

Chris BottomleySoftware Quality Lead EngineerCommented:
Honest answer ... I don't know but it is possible to adapt the method to check for the conditions within the script

Basically fire the script off every incoming mail and check the conditions as part of the script execution.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.