Consulting

Results 1 to 5 of 5

Thread: Search folder and move the item

  1. #1

    Search folder and move the item

    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

  2. #2
    Hi, it seems the solution is easier than I thought. I still don't understand why it doesn't work with two parts, but when I integrate the code at Part II into first part, it works and moves the emails to found folder.

    Below the working version, which I cleaned a bit.

    
    Option Explicit
    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
      
      'additons for move to folder
        Dim objNS As Outlook.NameSpace
      Dim objItem As Outlook.MailItem
      Set objNS = Application.GetNamespace("MAPI")
        Set objItem = Application.ActiveExplorer.Selection.Item(1)
      'additions for move to folder
    
    
      Set m_Folder = Nothing
      m_Find = ""
      m_Wildcard = False
    
    
      Name = InputBox("Find folder by name:", "Search folder & Move Item")
      If Len(Trim$(Name)) = 0 Then Exit Sub
      m_Find = "*" & Name & "*" '<--- good addition so that we don't need to add * everytime.
    
    
      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 or just move the item to it: " & vbCrLf & vbCrLf & m_Folder.FolderPath & vbNewLine & vbNewLine & "Yes = Activate the folder only" & vbNewLine & "No = Move the item and activate", vbQuestion Or vbYesNo) = vbYes Then
       
    'only activate the folder:
         
          Set Application.ActiveExplorer.CurrentFolder = m_Folder
          
    Else
    ' move the item to the found folder and activate to be sure:
    
    
    objItem.Move m_Folder '<-- where magic happens :)
    
    
       Set Application.ActiveExplorer.CurrentFolder = m_Folder   '<-- this line can be deactivated if not needed. 
        
        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

  3. #3
    VBAX Newbie
    Joined
    Nov 2023
    Location
    USA- EST
    Posts
    2
    Location

    Question Outlook Marco for "Search folder and move the item" no longer works

    Hi Nymphe1410,

    Thank you for your code. This code has been working for me for 2 weeks now and it has helped me tremendously but all of a sudden it no longer works. My trust center has macros enabled, I restarted the program, deleted the macro, and even changed the project name. The window would pop up to find the folder but it does not provide the follow-up path to go to the folder or move then go to the folder. Do you have any suggestions?


    Quote Originally Posted by nymphe1410 View Post
    Hi, it seems the solution is easier than I thought. I still don't understand why it doesn't work with two parts, but when I integrate the code at Part II into first part, it works and moves the emails to found folder.

    Below the working version, which I cleaned a bit.

    
    Option Explicit
    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
      
      'additons for move to folder
        Dim objNS As Outlook.NameSpace
      Dim objItem As Outlook.MailItem
      Set objNS = Application.GetNamespace("MAPI")
        Set objItem = Application.ActiveExplorer.Selection.Item(1)
      'additions for move to folder
    
    
      Set m_Folder = Nothing
      m_Find = ""
      m_Wildcard = False
    
    
      Name = InputBox("Find folder by name:", "Search folder & Move Item")
      If Len(Trim$(Name)) = 0 Then Exit Sub
      m_Find = "*" & Name & "*" '<--- good addition so that we don't need to add * everytime.
    
    
      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 or just move the item to it: " & vbCrLf & vbCrLf & m_Folder.FolderPath & vbNewLine & vbNewLine & "Yes = Activate the folder only" & vbNewLine & "No = Move the item and activate", vbQuestion Or vbYesNo) = vbYes Then
       
    'only activate the folder:
         
          Set Application.ActiveExplorer.CurrentFolder = m_Folder
          
    Else
    ' move the item to the found folder and activate to be sure:
    
    
    objItem.Move m_Folder '<-- where magic happens :)
    
    
       Set Application.ActiveExplorer.CurrentFolder = m_Folder   '<-- this line can be deactivated if not needed. 
        
        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

  4. #4
    VBAX Regular
    Joined
    Sep 2023
    Posts
    87
    Location
    Have you tried to debug your code to see if it is being called at all? VBA: How to Debug Code - Overview, Tools, Shortcut Keys | Wall Street Oasis

  5. #5
    VBAX Newbie
    Joined
    Nov 2023
    Location
    USA- EST
    Posts
    2
    Location
    I tried going through the steps. Nothing. I think it timed out and i received an "array index out of bounds outlook".

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •