[Last Call] Learn how to a build a cloud-first strategyRegister Now

  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 180
  • Last Modified:

Moving an email from Inbox to a sub-folder

I am trying to move a selected email item to a specific folder under the Inbox, but it fails on me because it fails to correctly assign the path to the desired location.

The code is below.  Using the Watch window, I can see that MoveToFolder is nothing.  What am I missing?

Dim ns As Outlook.NameSpace
    Dim MoveToFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    Dim MoveToHere As String
    Set ns = Application.GetNamespace("MAPI")

    MoveToHere = "M_H@metricuu.com\Inbox\Client\00_E44xx\E4422"
    'Set MoveToFolder = F.Folders
    Set MoveToFolder = ns.Folders.Item(MoveToHere)
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox ("No item selected")
        Exit Sub
    End If
    If MoveToFolder Is Nothing Then
        MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
    End If
    For Each objItem In Application.ActiveExplorer.Selection
        If MoveToFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.Move MoveToFolder
            End If
            End If
    Set objItem = Nothing
    Set MoveToFolder = Nothing
    Set ns = Nothing

End Sub
  • 2
  • 2
1 Solution

pls try

with this function

Set MoveToFolder = GetFolderPath("M_H@metricuu.com\Inbox\Client\00_E44xx\E4422").Items 

Function GetFolderPath(ByVal FldrPath As String) As Outlook.Folder

Dim oFldr As Outlook.Folder
Dim arrFldr As Variant
Dim Idx As Integer
arrFldr = Split(FldrPath, "\")
Set oFldr = Application.Session.Folders.Item(arrFldr(0))
If Not oFldr Is Nothing Then
    For Idx = 1 To UBound(arrFldr, 1)
        Dim SubFldrs As Outlook.Folders
        Set SubFldrs = oFldr.Folders
        Set oFldr = SubFldrs.Item(arrFldr(i))
        If oFldr Is Nothing Then
            Set GetFolderPath = Nothing
        End If
End If

Set GetFolderPath = oFldr
End Function

Open in new window

MoeMoe7Author Commented:

I put that function in there and I ran the code.  I can see that the function was called, but the MoveToFolder remained empty.

I replaced my line
Set MoveToFolder = ns.Folders.Item(MoveToHere)
with yours
Set MoveToFolder = GetFolderPath("M_H@metricuu.com\Inbox\Client\00_E44xx\E4422").Items

and added your function.

Unfort, it did not work.

Could you put a break point at line 24 of my code and run the code (F9)

then see in Locals the value of IDx and of oFldr

MoeMoe7Author Commented:

Thank you for you help.  I could not get your code to work, but it pointed me to here...

This is what finally worked.

Set MoveToFolder = GetFolder(DaFolder2)
'where DaFolder = "M_H@metricuu.com\Inbox\Client\00_E44xx\E4422"

Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"

  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

Open in new window

To be honest, I don't understand the differences.  But without your input, I would not have found it!

Thank you!

Featured Post

Get free NFR key for Veeam Availability Suite 9.5

Veeam is happy to provide a free NFR license (1 year, 2 sockets) to all certified IT Pros. The license allows for the non-production use of Veeam Availability Suite v9.5 in your home lab, without any feature limitations. It works for both VMware and Hyper-V environments

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now