Solved

Outlook 2007 emails to temp external folder

Posted on 2011-03-04
18
453 Views
Last Modified: 2012-08-13
Hi

Previously this site helped me created a macro (See code) that takes emails, appointments etc from my Outlook 2007 folder structure to a temp folder, (saveFolder = "G:\ServiceManagement\ChM\Change Library\temp")

This macro works 100%, and does what is required, but if a top level folder is selected it will copy all emails below and dump them in the same temp folder.

My new question is, can the macro be altered so that when you select the top level folder that folder and all sub folders will be copied to the new temp folder with new folders created inside the temp folder for each subfolder. (If that makes sense)

E.g

Outlook 2007

Main Folder
   Email 1
   Email 2
      Subfolder 1
         Email 1
         Email 2
         Appointment 1
         Email 3
      Subfolder 2
         Email 1
         Appointment 1
         Email 2
      Subfolder 3
         Email 1
         Etc
            
Destination Folder –
(saveFolder = "G:\ServiceManagement\ChM\Change Library\temp")

Temp Folder
Main Folder
            Email 1
            Email 2
      Subfolder 1
         Email 1
         Email 2
         Appointment 1
         Email 3
      Subfolder 2
         Email 1
         Appointment 1
         Email 2
      Subfolder 3
         Email 1
         Etc

Thanks
Public folderItemCount As Integer
 
Sub MoveEmails()
Dim myPSTs As MAPIFolder
Dim myFolder As MAPIFolder
Dim mai As MailItem
Dim saveFolder As String
    saveFolder = "G:\ServiceManagement\ChM\Change Library\temp"
        
        folderItemCount = 0
        Set myFolder = Application.GetNamespace("mapi").PickFolder
        saveFolder = saveFolder & "\Dated " & Format(Date, "yyyy mm dd")
        navtoDosFolder saveFolder, True
'        For Each myPSTs In Application.GetNamespace("mapi").folders
            recursor myFolder, saveFolder
'        Next
End Sub
Sub recursor(startFolder As MAPIFolder, saveTo As String)
Dim fldr As Outlook.MAPIFolder
Dim objitem As Object
Dim mai As Object
Dim Subject As String
Dim strFilter As String
Dim olmailitems As Outlook.Items
Dim del As Variant
Dim SortedItems As Items
 
    On Error Resume Next
    Set olmailitems = startFolder.Items
    olmailitems.Sort "ReceivedTime", False
    Set SortedItems = olmailitems
    
    ' process all the items in this folder
    For Each objitem In SortedItems
        If TypeName(objitem) = "MailItem" Or objitem.Class = olMeetingRequest Then
            folderItemCount = folderItemCount + 1
            Set mai = objitem
                         Subject = Format(mai.ReceivedTime, "yyyy-mm-dd hh-mm ") & Left(Replace(mai.Subject, """", " "), 60) & " Email " & folderItemCount
            For Each del In Array("/", ":", "*", "?", "<", ">", "|")
                Subject = Replace(Subject, del, " ")
            Next
                mai.SaveAs saveTo & "\" & Subject & ".msg", olMSG
        End If
    Next
    ' process all the subfolders of this folder
    For Each fldr In startFolder.Folders
        Call recursor(fldr, saveTo)
    Next
 
Set fldr = Nothing
End Sub
Public Function navToFolder(foldername As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfldr As Outlook.Folders
Dim reqdFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.Folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                reqdFolder.Folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.Folders
                Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set navToFolder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
Function navtoDosFolder(dosPath As String, Optional createFolders As Boolean) As Boolean
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
    navtoDosFolder = True
    If Right(dosPath, 1) = "\" Then dosPath = Left(dosPath, Len(dosPath) - 1)
    If Len(dosPath) = 0 Then
        navtoDosFolder = False
        Exit Function
    End If
    fldrs = Split(dosPath, "\")
    rootdir = fldrs(0)
    If Dir(rootdir, vbDirectory) = "" Then
        navtoDosFolder = False
        Exit Function
    End If
    For fldrIndex = 1 To UBound(fldrs)
        rootdir = rootdir & "\" & fldrs(fldrIndex)
        If Dir(rootdir, vbDirectory) = "" Then
            If createFolders Then
                MkDir (rootdir)
            Else
                navtoDosFolder = False
            End If
        End If
    Next
End Function

Open in new window

0
Comment
Question by:Andrewajp002
  • 9
  • 9
18 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35034800
You want to keep the pst folder structure in the disk folder rather than the current flat file representation?

Chris
0
 

Author Comment

by:Andrewajp002
ID: 35035192
Hi Chris

Im not 100% what you mean there :( lol

What im after is that if I ahve a main folder called say archive with a number of subfolders, this will be replicated in the temp folder outside of outlook, so for example

Archive
  subfolder 12345
  subfolder 12346

this would be created in temp with all respective emails etc in each folder / subfolder being replicated in the correct folder.  At present if you choose the archive it will copy everything in subfolder 12345 & 12346 and put them in one folder which is created with the current date.

Does that make sense?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35035240
>>> Does that make sense?

Obviously more sense than my words but yes indeed and I believe we are saying the same thing.  Will hopefully look at it later today.

Chris
0
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35038989
Replace the subs MoveEmails & recursor as below and see.

Basically I have kept everything pretty much the same for exmple the folder name still contains the date although I have appended the parent folder name to the end.

Chris
Sub MoveEmails()
Dim myPSTs As MAPIFolder
Dim MyFolder As MAPIFolder
Dim saveFolder As String
    saveFolder = "G:\ServiceManagement\ChM\Change Library\temp"
    saveFolder = "c:\temp"
        
        folderItemCount = 0
        Set MyFolder = Application.GetNamespace("mapi").PickFolder
        saveFolder = saveFolder & "\Dated " & Format(Date, "yyyy mm dd") & " " & MyFolder.name
        navtoDosFolder saveFolder, True
'        For Each myPSTs In Application.GetNamespace("mapi").folders
            recursor MyFolder, saveFolder
'        Next
End Sub
Sub recursor(startFolder As MAPIFolder, saveTo As String)
Dim fldr As Outlook.MAPIFolder
Dim objItem As Object
Dim Subject As String
Dim strFilter As String
Dim olmailitems As Outlook.items
Dim del As Variant
Dim SortedItems As items
Dim mai As Object
 
    On Error Resume Next
    navtoDosFolder saveTo, True
    Set olmailitems = startFolder.items
    olmailitems.Sort "ReceivedTime", False
    Set SortedItems = olmailitems
    
    ' process all the items in this folder
    For Each objItem In SortedItems
        If TypeName(objItem) = "MailItem" Then
            folderItemCount = folderItemCount + 1
            Set mai = objItem
            Subject = Format(mai.ReceivedTime, "yyyy-mm-dd hh-mm ") & Left(Replace(mai.Subject, """", " "), 60) & " Email " & folderItemCount
            For Each del In Array("/", ":", "*", "?", "<", ">", "|")
                Subject = Replace(Subject, del, " ")
            Next
            mai.saveas saveTo & "\" & Subject & ".msg", olMsg
        End If
    Next
    ' process all the subfolders of this folder
    For Each fldr In startFolder.folders
        Call recursor(fldr, saveTo & "\" & fldr.name)
    Next
 
Set fldr = Nothing
End Sub

Open in new window

0
 

Author Comment

by:Andrewajp002
ID: 35056169
Hi Chris

Thanks for that, I ahve run this but I cannot tell if it works, well as far as I can see it doesnt 100% as no folders are created in saveFolder = "G:\ServiceManagement\ChM\Change Library\temp" and no emails copied over.

Im not sure if ive done something wrong?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35056295
Can you upload the code as you have it now?

Chris
0
 

Author Comment

by:Andrewajp002
ID: 35067737
Sub MoveEmails()
Dim myPSTs As MAPIFolder
Dim MyFolder As MAPIFolder
Dim saveFolder As String
    saveFolder = "G:\ServiceManagement\ChM\Change Library\temp"
    saveFolder = "c:\temp"
       
        folderItemCount = 0
        Set MyFolder = Application.GetNamespace("mapi").PickFolder
        saveFolder = saveFolder & "\Dated " & Format(Date, "yyyy mm dd") & " " & MyFolder.Name
        navtoDosFolder saveFolder, True
'        For Each myPSTs In Application.GetNamespace("mapi").folders
            recursor MyFolder, saveFolder
'        Next
End Sub
Sub recursor(startFolder As MAPIFolder, saveTo As String)
Dim fldr As Outlook.MAPIFolder
Dim objItem As Object
Dim Subject As String
Dim strFilter As String
Dim olmailitems As Outlook.Items
Dim del As Variant
Dim SortedItems As Items
Dim mai As Object
 
    On Error Resume Next
    navtoDosFolder saveTo, True
    Set olmailitems = startFolder.Items
    olmailitems.Sort "ReceivedTime", False
    Set SortedItems = olmailitems
   
    ' process all the items in this folder
    For Each objItem In SortedItems
        If TypeName(objItem) = "MailItem" Then
            folderItemCount = folderItemCount + 1
            Set mai = objItem
            Subject = Format(mai.ReceivedTime, "yyyy-mm-dd hh-mm ") & Left(Replace(mai.Subject, """", " "), 60) & " Email " & folderItemCount
            For Each del In Array("/", ":", "*", "?", "<", ">", "|")
                Subject = Replace(Subject, del, " ")
            Next
            mai.SaveAs saveTo & "\" & Subject & ".msg", olMSG
        End If
    Next
    ' process all the subfolders of this folder
    For Each fldr In startFolder.Folders
        Call recursor(fldr, saveTo & "\" & fldr.Name)
    Next
 
Set fldr = Nothing
End Sub
0
 

Author Comment

by:Andrewajp002
ID: 35067832
ok, so we have all the facts

I added this to a new module yesterday and renamed the old one.  It seemed to work without error but just didnt show any results.

Ive today now exported the other module, tried to run the macro and it now comes up with an compile error sub or function not defined on row 11,  navtoDosFolder saveFolder, True
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35067843
I did say I followed the earlier pattern so rather than folder:

"G:\ServiceManagement\ChM\Change Library\temp"
Look for
"G:\ServiceManagement\ChM\Change Library\temp\Dated 2011 03 08"

Chris
0
 

Author Comment

by:Andrewajp002
ID: 35067865
Ok, next update, I have located the folders in the c:\temp folder.  That seems to work fine.

I then tried to make the folder go to the network drive by editing out the saveFolder = "c:\temp", this now seems to work fine.

I will carry out some tests before I close.

Thanks for your help chris.
0
 

Author Comment

by:Andrewajp002
ID: 35067877
Chris

Issue before was the line left in saving the files to c:\temp, that confused me alittle, but after editing that out it seems fine.

Many Thanks
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35067900
Oh bother ... I do apologise that was of course for my testing!
0
 

Author Comment

by:Andrewajp002
ID: 35067965
ok looks good, back to the same issue though as I had first time round that it is only copying the emails across and not all outlook items eg appointments etc
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35068125
That's ok then ... we address the item types as a related question because the handling for them could be a problem ... but as a first stage try the following ... but be prepared to go back to the previously supplied code!

Chris
Sub MoveEmails()
Dim myPSTs As MAPIFolder
Dim MyFolder As MAPIFolder
Dim saveFolder As String
    saveFolder = "G:\ServiceManagement\ChM\Change Library\temp"
    saveFolder = "c:\temp"
        
        folderItemCount = 0
        Set MyFolder = Application.GetNamespace("mapi").PickFolder
        saveFolder = saveFolder & "\Dated " & Format(Date, "yyyy mm dd") & " " & MyFolder.Name
        navtoDosFolder saveFolder, True
'        For Each myPSTs In Application.GetNamespace("mapi").folders
            recursor MyFolder, saveFolder
'        Next
End Sub
Sub recursor(startFolder As MAPIFolder, saveTo As String)
Dim fldr As Outlook.MAPIFolder
Dim objItem As Object
Dim Subject As String
Dim strFilter As String
Dim olmailitems As Outlook.Items
Dim del As Variant
Dim SortedItems As Items
Dim mai As Object
 
    On Error Resume Next
    navtoDosFolder saveTo, True
    Set olmailitems = startFolder.Items
    olmailitems.Sort "ReceivedTime", False
    Set SortedItems = olmailitems
    
    ' process all the items in this folder
    For Each objItem In SortedItems
'        If TypeName(objItem) = "MailItem" Then
            folderItemCount = folderItemCount + 1
            Set mai = objItem
            Subject = Format(mai.ReceivedTime, "yyyy-mm-dd hh-mm ") & Left(Replace(mai.Subject, """", " "), 60) & " Email " & folderItemCount
            For Each del In Array("/", ":", "*", "?", "<", ">", "|")
                Subject = Replace(Subject, del, " ")
            Next
            mai.SaveAs saveTo & "\" & Subject & ".msg", olMSG
'        End If
    Next
    ' process all the subfolders of this folder
    For Each fldr In startFolder.Folders
        Call recursor(fldr, saveTo & "\" & fldr.Name)
    Next
 
Set fldr = Nothing
End Sub

Open in new window

0
 

Author Comment

by:Andrewajp002
ID: 35068420
Hi Chris

Looking good, 1 issue

1)  At the end of each email etc copied there is an item count for that folder, eg email 1, email 2 etc.

This email count does not reset when moving between folders eg folder 1, email 1, email 2 FOLDER 2, email 3, email 4, email 5 etc.

The count does not reset to one for the next folder.

Thanks for your help on this chris
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 35068481
Resetting count for each folder

Chris
Sub MoveEmails()
Dim myPSTs As MAPIFolder
Dim MyFolder As MAPIFolder
Dim saveFolder As String
    
    saveFolder = "G:\ServiceManagement\ChM\Change Library\temp"
    saveFolder = "c:\temp"
        
'        folderItemCount = 0
        Set MyFolder = Application.GetNamespace("mapi").PickFolder
        saveFolder = saveFolder & "\Dated " & Format(Date, "yyyy mm dd") & " " & MyFolder.name
        navtoDosFolder saveFolder, True
'        For Each myPSTs In Application.GetNamespace("mapi").folders
            recursor MyFolder, saveFolder
'        Next
End Sub
Sub recursor(startFolder As MAPIFolder, saveTo As String)
Dim fldr As Outlook.MAPIFolder
Dim objItem As Object
Dim Subject As String
Dim strFilter As String
Dim olmailitems As Outlook.items
Dim del As Variant
Dim SortedItems As items
Dim mai As Object
 
    On Error Resume Next
    navtoDosFolder saveTo, True
    Set olmailitems = startFolder.items
    olmailitems.Sort "ReceivedTime", False
    Set SortedItems = olmailitems
    
    ' process all the items in this folder
    folderItemCount = 0
    For Each objItem In SortedItems
'        If TypeName(objItem) = "MailItem" Then
            folderItemCount = folderItemCount + 1
            Set mai = objItem
            Subject = Format(mai.ReceivedTime, "yyyy-mm-dd hh-mm ") & Left(Replace(mai.Subject, """", " "), 60) & " Email " & folderItemCount
            For Each del In Array("/", ":", "*", "?", "<", ">", "|")
                Subject = Replace(Subject, del, " ")
            Next
            mai.SaveAs saveTo & "\" & Subject & ".msg", olMSG
'        End If
    Next
    ' process all the subfolders of this folder
    For Each fldr In startFolder.folders
        Call recursor(fldr, saveTo & "\" & fldr.name)
    Next
 
Set fldr = Nothing
End Sub

Open in new window

0
 

Author Comment

by:Andrewajp002
ID: 35068554
That is top notch work chris.  That works spot on.

Apart from the item icons all being emails and not emails, appointments etc ;) lol Joke ;)

1 question though, when I remove module 1 which is the original module, it then comes up with the  "navtoDosFolder saveFolder, True" is not defined error, when i add the module back its fine.  Strange.  But works fine with both the modules there so I will leave the old one there for the time being.

Great work Chris.  Cheers

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35068634
Not sure about what is in which module ... but you need navtoDosFolder and navToFolder functions which have NOT been included in any of the posts here because they were unchanged.  If you add a copy of them to your new module then the old one ought to be deleted without any problem ... recommend archive as part of the delete though)

Chris
0

Featured Post

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

816 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now