Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Outlook 2007 emails to temp external folder

Posted on 2011-03-04
18
Medium Priority
?
464 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:Andrew Parker
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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:Andrew Parker
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
NEW Veeam Agent for Microsoft Windows

Backup and recover physical and cloud-based servers and workstations, as well as endpoint devices that belong to remote users. Avoid downtime and data loss quickly and easily for Windows-based physical or public cloud-based workloads!

 
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:Andrew Parker
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:Andrew Parker
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:Andrew Parker
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:Andrew Parker
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:Andrew Parker
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:Andrew Parker
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:Andrew Parker
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 2000 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:Andrew Parker
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

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

This article will help to fix the below error for MS Exchange server 2010 I. Out Of office not working II. Certificate error "name on the security certificate is invalid or does not match the name of the site" III. Make Internal URLs and External…
In this article I discuss my selections of the Top Four free Outlook OST File Viewers available. Open, view and read even damaged OST files by using these tools. They all provide a clear preview of all data such as emails, notes, tasks, calendars, e…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

722 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