• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Moving Outlook Inbox emails to different subfolders

buvana

New Member
Hi
I am a newbie in VBA and in the learning process. I found this code while googling. With this code I was able to transfer emails based on the mail id or subject to respective folders when I was using Excel 2010. But now I am using Excel 2013. I have already marked reference to Microsoft outlook library and Microsoft Scripting runtime. I get runtime error: "438" - Object doesn't support this property or method. Can anyone help me in resolving this issue.

Thanks in advance.

Stay Safe. Work Safe.

Buvana


Code:
Option Explicit
Const olFolderInbox = 6
Sub moveOutlookMails()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim r As Range
Dim dictMailID As Object
Dim dictSubject As Object
Dim vSubjKeys As Variant

Dim olApp As Object 'Outlook.Application
Dim olNameSpace As Object 'Outlook.Namespace
Dim olItem As Object 'Outlook.MailItem
Dim olInbox As Object 'Outlook.MAPIFolder
Dim olFolder As Object 'Outlook.MAPIFolder

Dim i As Long
Dim j As Long

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet

    Set dictMailID = CreateObject("Scripting.Dictionary")    'keeps unique keys
    Set dictSubject = CreateObject("Scripting.Dictionary")

    'load mail_ID and subject keys
    Set rng = wks.Range("C2:C" & wks.Range("C" & wks.Rows.Count).End(xlUp).Row)

    For Each r In rng
        If r.Offset(, -1).Value = "MAIL_ID" Then
            If Not dictMailID.exists(r.Value) Then dictMailID.Add r.Value, r.Offset(, -2).Value
        Else    'it must be a subject
            If Not dictSubject.exists(r.Value) Then dictSubject.Add r.Value, r.Offset(, -2).Value
        End If
    Next r

    vSubjKeys = dictSubject.keys

    'load an instance of Outlook to process each mail item

    Set olApp = CreateObject("Outlook.Application")
    Set olNameSpace = olApp.GetNamespace("MAPI")

    'Set olInbox = olNameSpace.PickFolder
    Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)

    'read each mail item to determine if it needs to be moved to subfolder

    For j = olInbox.Items.Count To 1 Step -1
        Set olItem = olInbox.Items(j)
        'check for match in mailID
        If dictMailID.exists(olItem.SenderName) Then     'found a matching MAIL_ID!!!    <-- Here the error occurs
            'store in dictMailID(olItem.Sender.Name) folder
            'Debug.Print "Found " & olItem.Sender.Name & " for folder " & dictMailID(olItem.Sender.Name)
            
            If CheckForFolder(dictMailID(olItem.SenderName)) Then    'folder exists
                Set olFolder = olInbox.Folders.Item(dictMailID(olItem.SenderName))
            Else
                Set olFolder = CreateSubFolder(dictMailID(olItem.SenderName))
            End If
            'move item to that folder
            olItem.Move olFolder
        Else
            'check for match in Subject
            For i = LBound(vSubjKeys) To UBound(vSubjKeys)
                If olItem.Subject Like Replace(vSubjKeys(i), "%", "*") Then    'see if pattern matches
                    'store in dictSubject(vsubjKeys(i)) folder
                    'Debug.Print "Found " & olItem.Subject & " for folder " & dictSubject(vSubjKeys(i))
                    
                    If CheckForFolder(dictSubject(vSubjKeys(i))) Then    'folder exists
                        Set olFolder = olInbox.Folders.Item(dictSubject(vSubjKeys(i)))
                    Else
                        Set olFolder = CreateSubFolder(dictSubject(vSubjKeys(i)))
                    End If
                    'move item to that folder
                    olItem.Move olFolder
                End If
            Next i
        End If
    Next j

gracefulExit:

    dictMailID.RemoveAll
    dictSubject.RemoveAll
    Set dictMailID = Nothing
    Set dictSubject = Nothing
    Set olApp = Nothing

    MsgBox "Process Complete!"


End Sub

Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Object 'Outlook.Application
Dim olNS As Object 'Outlook.Namespace
Dim olInbox As Object 'Outlook.MAPIFolder
Dim FolderToCheck As Object 'Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

    ' try to set an object reference to specified folder
    On Error Resume Next
    Set FolderToCheck = olInbox.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Object 'Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Object 'Outlook.Application
Dim olNS As Object 'Outlook.Namespace
Dim olInbox As Object 'Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

    Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function
 

Attachments

  • Transfer Outlook mails to specific folder and save.xlsm
    31.7 KB · Views: 12
Back
Top