Consulting

Results 1 to 2 of 2

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

Posting Permissions

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