Ashringg
New Member
- Outlook version
- Outlook 2016 32 bit
- Email Account
- Outlook.com (as MS Exchange)
Hi All,
I found this very useful macro from user Nymphe1410, on another form, and it has been helping my workflow for over 2 weeks but it is no longer working. Do you have any suggestions on how I can fix this?
Purpose: The purpose of this macro is to move an email to a found folder that is nestled inside a folder one of my folders inside my inbox. The macro would allow me to search for the folder then go to the folder or move the email (or emails) and go to the folder.
This code was been working for me for 2 weeks but all of a sudden it no longer works. Note: 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 enter the folder I want to find but it does not go past that.
I found this very useful macro from user Nymphe1410, on another form, and it has been helping my workflow for over 2 weeks but it is no longer working. Do you have any suggestions on how I can fix this?
Purpose: The purpose of this macro is to move an email to a found folder that is nestled inside a folder one of my folders inside my inbox. The macro would allow me to search for the folder then go to the folder or move the email (or emails) and go to the folder.
This code was been working for me for 2 weeks but all of a sudden it no longer works. Note: 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 enter the folder I want to find but it does not go past that.
Code:
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