Hello everyone,

I've tried to read all topics with "move" item to folders but unfortunately despite trying to modify and adapt those codes, I failed.

There was one post which was similar to my folder structure but still was not the answer I was looking for. Almost all posts about moving are trying to move objects to predefined folders. Those are hard coded into the script, but I need to have the path as a variable.

I'm working in project business, so for each quotation and order I have subfolders. Those are also nested under further parent folders like year or country. Basically I want to keep all relevant emails of a particular job in a separate Outlook folder. Of course now I have hundred of folders.

I'm using a macro for finding those folders. I think this is quite popular and well known macro, which can be found below.

What I want is to extend this macro to move the email I select to the found folder above. This can be an extension or also secondary macro to run. For example:

Run the macro: Find folder with the name *jobsite*. Get path of this folder. Move the active item (email) to this folder (Job123-jobsite-xyz).

When I set the m_Folders variable as Outlook.Folders I always get errors. Basically the code works until move command.

Thank you very much for helping or at least reading it.

My code is:
Part I: For finding folders only. Works perfectly and quite fast too.

Private m_Folder As Outlook.MAPIFolder
Private m_Find As String
Private m_Wildcard As Boolean
 
Private Const SpeedUp As Boolean = False
Private Const StopAtFirstMatch As Boolean = True
 
Public Sub FindFolder()
  Dim Name$
  Dim Folders As Outlook.Folders
  Dim m_Folder2 As Outlook.MAPIFolder
  Dim m_Folder3 As String
  
  'additions for move to folder
 
  Set m_Folder = Nothing
  m_Find = ""
  m_Wildcard = False
 
  Name = InputBox("Find name:", "Search folder")
  If Len(Trim$(Name)) = 0 Then Exit Sub
  m_Find = "*" & Name & "*"
 
  m_Find = LCase$(m_Find)
  m_Find = Replace(m_Find, "%", "*")
  m_Wildcard = (InStr(m_Find, "*"))
 
  Set Folders = Application.Session.Folders
  LoopFolders Folders
 
  If Not m_Folder Is Nothing Then
  
    If MsgBox("Activate folder: " & vbCrLf & m_Folder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
   
   
'activate the folder:
      
      Set Application.ActiveExplorer.CurrentFolder = m_Folder
      
Else
'  **** don't go to the folder, instead move the item - basically this is what I'm trying ****
 
Set m_Folder2 = m_Folder
 
 MoveCopyMessage (m_Folder2)
 
    End If
  Else
    MsgBox "Not found", vbInformation
  End If
End Sub
 
Private Sub LoopFolders(Folders As Outlook.Folders)
  Dim F As Outlook.MAPIFolder
  Dim Found As Boolean
  
  If SpeedUp = False Then DoEvents
 
  For Each F In Folders
    If m_Wildcard Then
      Found = (LCase$(F.Name) Like m_Find)
    Else
      Found = (LCase$(F.Name) = m_Find)
    End If
 
    If Found Then
      If StopAtFirstMatch = False Then
        If MsgBox("Found: " & vbCrLf & F.FolderPath & vbCrLf & vbCrLf & "Continue?", vbQuestion Or vbYesNo) = vbYes Then
          Found = False
        End If
      End If
    End If
    If Found Then
      Set m_Folder = F
      Exit For
    Else
      LoopFolders F.Folders
      If Not m_Folder Is Nothing Then Exit For
    End If
  Next
End Sub
Part II: Move the item to above found folder. This is a macro which I found somewhere else too. I played around so there are unnecessary parts left. I think I fail to the integrate the destination folder in this script. I tried to play with m_Folder.FolderPath but objItem.Move doesn't recognize it. 

Sub MoveCopyMessage(m_Folder2)
 
    Dim objNS As Outlook.NameSpace
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    Dim objCopy As Outlook.MailItem
    
    Set objNS = Application.GetNamespace("MAPI")
 
' Set the destination folders
'    Set objDestFolder = objNS.Folders("Public Folders - alias-domain") _
         .Folders("All Public Folders").Folders("Old")
 
    Set objItem = Application.ActiveExplorer.Selection.Item(1)
    
     ' move to a subfolder of the Inbox
     
'  Set objDestFolder = m_Folder2
  
 ' copy and move first  - I'm trying to see whether this works, for now, it is copying the email successfully
     Set objCopy = objItem.Copy
      objCopy.Move m_Folder2
' to move
' objItem.Move objDestFolder
 
        
    Set objDestFolder = Nothing
    Set objNS = Nothing
End Sub
One more thanks if you read until here