Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 466
  • Last Modified:

Outlook 2007 emails to temp external folder

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
Andrew Parker
Asked:
Andrew Parker
  • 9
  • 9
1 Solution
 
Chris BottomleyCommented:
You want to keep the pst folder structure in the disk folder rather than the current flat file representation?

Chris
0
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
>>> 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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
Chris BottomleyCommented:
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
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
Can you upload the code as you have it now?

Chris
0
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
Oh bother ... I do apologise that was of course for my testing!
0
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
Andrew ParkerIT Field Systems Delivery OfficerAuthor Commented:
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
 
Chris BottomleyCommented:
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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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