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
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