Solved

Outlook 2007 emails to temp external folder

Posted on 2011-03-04
18
450 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
 
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
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

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

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Outlook Free & Paid Tools
This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
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…
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…

707 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