Solved

export outlook folder structure and all the items within to network drive

Posted on 2012-04-06
19
1,235 Views
Last Modified: 2012-04-09
Dear experts,


what we want to accomplish is to try export selected outlook folders with all their contents to a network drive (aka file server) using a VBScript (choice from the management).

It can be any folders & nested subfolders within outlook even public folders.
Content can be contacts, mails or office files (xls, doc, ppt,...).
The mail items must be exported as msg files and has to keep the hierarchal folder structure during the export.

We are looking for several weeks on googling without any luck :(.

Can one of you experts help us out please? This would be really wonderful.

Kind regards,
0
Comment
Question by:DigitBoy
  • 11
  • 8
19 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
That's potentially possible using VBA but first off why / what level.

For example you could archive everything off but I am imagining that for the purpose of this question you want everything exporting to the DOS folder system.

e.g. for each folder then for each item then for each attachment?

If so how would the structure be maintained since the attachments would not be immediately attributable to a particular email.  Also some of the outlook folders may carry unacceptable characters for a dos folder so what happens in this case?

If the attachments were kept with the email as outlook mail items then this would be easier but the mail items will still be outlook mail items as saved.

ANy thoughts?

Chris
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi,

thank you for you response.

yes we want to export to ntfs folder system (eg storage) and we are aware of some disadvantages.

When you save it as msg file the attachment within mail will stay intact. There is no need to extract attachments from mails. We want to save all the mail items as msg files on a network storage and as wel fo all other non mail items have to also be saved on a storage.

If some characters are not supported by ntfs is it then possible to replace some characters by supporterd ones?

The reason why we want such kind of solution is that we are going to migrate to google. And we don't want to archive everything in pst files, but either on file storages. The data that we have is around 86GB and we don't want to everything upload to the cloud.

K regs
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
It is perfectly feasible to do this via VBA though the export will take a while, a long while, a long long long ...... long while but it is doable and I believe I did something of the sort previously so I will look that up rather than start from scratch

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Check the solution here and let me know how you might need it adapting:

http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/Q_26908386.html

Chris
0
 

Author Comment

by:DigitBoy
Comment Utility
thanks a lot Chris. I will try out and will come asap back to you.
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,

I've found this script on MS gallery http://gallery.technet.microsoft.com/scriptcenter/739e3d04-9f30-4517-a876-15678555a846.

Sorry for asking, but is it possible to adapt this script just to do followng please (I'm totally a zero in programming)?

- select folder within outlook wich we want to export
- keep outlook folder structure when exporting to a file storage
    --> eg:
              -Inbox
                 -testfolder (=folder)
                     -Msg file
                     ...
    --> eg:
              -Public folders
                  -Accountant (=folder)
                     -dep1 (=folder)
                          - msg file
                          - test.doc  
- export mail items as "msg" files
- export all other non-mail items (eg contacts, office documents)
- export also folders from Public folders in outlook

I have to appologize for asking you so much, but alone nor mine colleagues  are able to accomplish this.

K regs
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Not easily, apart from the VBA aspect ... easily sorted, what was the issue with the script I directed you to which takes care of recursion?

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
'My' script as VBS:

Option Explicit
Dim fso

Q_26908386

Sub Q_26908386()
Dim fldr
dim strRootDir
Dim olkApp
    
    strRootDir = "c:\deleteme"
    Set fso = CreateObject("scripting.filesystemobject")
    Set olkApp = CreateObject("outlook.application")
    Set fldr = olkApp.Session.pickfolder
    Q_26908386_recur fldr, strRootDir & "/" & FileNameCharsOnly(fldr.name)
'    For Each fldr In Application.Session.folders
'        Q_26908386_recur fldr, strRootDir
'    Next
    Set fso = Nothing

End Sub

Sub Q_26908386_recur(fldr, DOSFolderPath)
Dim subFldr
Dim mai

    'Do the root export
    If fldr.DefaultItemType = 0 Then
        navtoDosFolder DOSFolderPath, True
        For Each mai In fldr.items
            If mai.Class = 43 Then
                If mai.Subject = "" Then
                ElseIf mai.BodyFormat = 2 Then
                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".htm"), 5
                ElseIf mai.BodyFormat = 3 Then
                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".rtf"), 1
                Else
                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".msg"), 3
                End If
            End If
        Next
    End If
    'Do the recursion
    For Each subFldr In fldr.folders
        Q_26908386_recur subFldr, DOSFolderPath & "\" & FileNameCharsOnly(subFldr.name)
    Next

End Sub

Function FileNameCharsOnly(str)
Dim regEx
Dim matches
Dim arr()
Dim cnt
Dim dirColon
    
    dirColon = Mid(str, 2, 1) = ":"
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^A-Za-z0-9$ %'\-_@~`\(\)\+\\,;=\[\]§-ÿ]"
    End With
    FileNameCharsOnly = regEx.Replace(str, " ")
    regEx.Pattern = " {2,}"
    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")
    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)

End Function

Function navtoDosFolder(dosPath, createFolders)
Dim fldrs
Dim rootdir
Dim fldrIndex
    
    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 Not fso.folderexists(rootdir) Then
        navtoDosFolder = False
        Exit Function
    End If
    For fldrIndex = 1 To UBound(fldrs)
        rootdir = rootdir & "\" & fldrs(fldrIndex)
        If Not fso.folderexists(rootdir) Then
            If createFolders Then
                fso.createfolder(rootdir)
            Else
                navtoDosFolder = False
            End If
        End If
    Next
End Function

Function getSaveName(strDosNameandPath)
Dim fn
Dim ft
Dim intIncrement

    fn = Left(strDosNameandPath, InStrRev(strDosNameandPath, ".") - 1)
    ft = Right(strDosNameandPath, Len(strDosNameandPath) - InStrRev(strDosNameandPath, ".") + 1)
        Do While fso.FileExists(fn & "_" & intIncrement & ft)
            intIncrement = intIncrement + 1
        Loop
        getSaveName = fn & "_" & intIncrement & ft

End Function

Open in new window


Chris
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,

sorry for late response. Thank you for providing the code.

The code is exporting mail items as htm files and not as msg files. The non mail items like *.doc/xls.. are not exported.

I saw also there seems to be a problem when it has to much nested subfolders (more then 260 characters).

K rgs
0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
>>> The code is exporting mail items as html
By default I saved mails as the format they were received as, but see below

>>> The non mail items like *.doc/xls.. are not exported.
They are in my tests albeit where mails are msg type

>>> to much nested subfolders
?If they are nested that deep in outlook then possible. If it is an error in the code then can you provide an example of the outlook folder structure and corresponding dos folder.

Option Explicit
Dim fso

Q_26908386

Sub Q_26908386()
Dim fldr
dim strRootDir
Dim olkApp
    
    strRootDir = "c:\deleteme"
    Set fso = CreateObject("scripting.filesystemobject")
    Set olkApp = CreateObject("outlook.application")
    Set fldr = olkApp.Session.pickfolder
    Q_26908386_recur fldr, strRootDir & "/" & FileNameCharsOnly(fldr.name)
'    For Each fldr In Application.Session.folders
'        Q_26908386_recur fldr, strRootDir
'    Next
    Set fso = Nothing

End Sub

Sub Q_26908386_recur(fldr, DOSFolderPath)
Dim subFldr
Dim mai

    'Do the root export
    If fldr.DefaultItemType = 0 Then
        navtoDosFolder DOSFolderPath, True
        For Each mai In fldr.items
            If mai.Class = 43 Then
                If mai.Subject = "" Then
'                ElseIf mai.BodyFormat = 2 Then
'                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".htm"), 5
'                ElseIf mai.BodyFormat = 3 Then
'                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".rtf"), 1
                Else
                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".msg"), 3
                End If
            End If
        Next
    End If
    'Do the recursion
    For Each subFldr In fldr.folders
        Q_26908386_recur subFldr, DOSFolderPath & "\" & FileNameCharsOnly(subFldr.name)
    Next

End Sub

Function FileNameCharsOnly(str)
Dim regEx
Dim matches
Dim arr()
Dim cnt
Dim dirColon
    
    dirColon = Mid(str, 2, 1) = ":"
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^A-Za-z0-9$ %'\-_@~`\(\)\+\\,;=\[\]§-ÿ]"
    End With
    FileNameCharsOnly = regEx.Replace(str, " ")
    regEx.Pattern = " {2,}"
    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")
    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)

End Function

Function navtoDosFolder(dosPath, createFolders)
Dim fldrs
Dim rootdir
Dim fldrIndex
    
    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 Not fso.folderexists(rootdir) Then
        navtoDosFolder = False
        Exit Function
    End If
    For fldrIndex = 1 To UBound(fldrs)
        rootdir = rootdir & "\" & fldrs(fldrIndex)
        If Not fso.folderexists(rootdir) Then
            If createFolders Then
                fso.createfolder(rootdir)
            Else
                navtoDosFolder = False
            End If
        End If
    Next
End Function

Function getSaveName(strDosNameandPath)
Dim fn
Dim ft
Dim intIncrement

    fn = Left(strDosNameandPath, InStrRev(strDosNameandPath, ".") - 1)
    ft = Right(strDosNameandPath, Len(strDosNameandPath) - InStrRev(strDosNameandPath, ".") + 1)
        Do While fso.FileExists(fn & "_" & intIncrement & ft)
            intIncrement = intIncrement + 1
        Loop
        getSaveName = fn & "_" & intIncrement & ft

End Function

Open in new window


Chris
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,

I will try the new code and will come back to you with feedback.
This is the error message for too long Folder Long folder namenames

K rgs
0
 

Author Comment

by:DigitBoy
Comment Utility
Wow Chris, your code exported the mail items as msg :D. Really fantastic and with right folder structure. I will test further :).
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,

I'm really amazed about your coding skills. Your code worked very well :D.
I had some error messages Maybe it is related to the following characters. I'm not sure about.
These are characters that I've found in some folders:
=¨$µ%ù@"#*/\

error:
Line 38
Char 21
Error: the operation failed
code: 80030003

The 2nd error message is long folder path.

K rgs
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
Comment Utility
The long names are likely to be the subjects of the emails.  If you accept using something else for the subjects then maybe that will help ... for example every email has a unique id and if we use that whilst it may not be obvious from the file name what it is ... it will still have the right subject but hopefully minimise the risk of long file names ... in passing it would also fix the character issue you refer to.

Option Explicit
Dim fso
Dim max,min
max=1000000
min=1
Randomize

Q_26908386

Sub Q_26908386()
Dim fldr
dim strRootDir
Dim olkApp
    
    strRootDir = "c:\deleteme"
    Set fso = CreateObject("scripting.filesystemobject")
    Set olkApp = CreateObject("outlook.application")
    Set fldr = olkApp.Session.pickfolder
    Q_26908386_recur fldr, strRootDir & "/" & FileNameCharsOnly(fldr.name)
'    For Each fldr In Application.Session.folders
'        Q_26908386_recur fldr, strRootDir
'    Next
    Set fso = Nothing

End Sub

Sub Q_26908386_recur(fldr, DOSFolderPath)
Dim subFldr
Dim mai

    'Do the root export
    If fldr.DefaultItemType = 0 Then
        navtoDosFolder DOSFolderPath, True
        For Each mai In fldr.items
            If mai.Class = 43 Then
                If mai.Subject = "" Then
'                ElseIf mai.BodyFormat = 2 Then
'                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".htm"), 5
'                ElseIf mai.BodyFormat = 3 Then
'                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".rtf"), 1
                Else
'                    mai.saveas getSaveName(DOSFolderPath & "\" & FileNameCharsOnly(mai.Subject) & ".msg"), 3
					If mai.entryid <> "" Then
	                    mai.saveas getSaveName(DOSFolderPath & "\" & "Mail " & mai.entryid & ".msg"), 3
	                Else
	                MsgBox DOSFolderPath & "\" & "mail " & Date() & Int((max-min+1)*Rnd+min) & ".msg"
	                    mai.saveas getSaveName(DOSFolderPath & "\" & "mail " & Date() & Int((max-min+1)*Rnd+min) & ".msg"), 3
	                End if
                End If
            End If
        Next
    End If
    'Do the recursion
    For Each subFldr In fldr.folders
        Q_26908386_recur subFldr, DOSFolderPath & "\" & FileNameCharsOnly(subFldr.name)
    Next

End Sub

Function FileNameCharsOnly(str)
Dim regEx
Dim matches
Dim arr()
Dim cnt
Dim dirColon
    
    dirColon = Mid(str, 2, 1) = ":"
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^A-Za-z0-9$ %'\-_@~`\(\)\+\\,;=\[\]§-ÿ]"
    End With
    FileNameCharsOnly = regEx.Replace(str, " ")
    regEx.Pattern = " {2,}"
    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")
    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)

End Function

Function navtoDosFolder(dosPath, createFolders)
Dim fldrs
Dim rootdir
Dim fldrIndex
    
    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 Not fso.folderexists(rootdir) Then
        navtoDosFolder = False
        Exit Function
    End If
    For fldrIndex = 1 To UBound(fldrs)
        rootdir = rootdir & "\" & fldrs(fldrIndex)
        If Not fso.folderexists(rootdir) Then
            If createFolders Then
                fso.createfolder(rootdir)
            Else
                navtoDosFolder = False
            End If
        End If
    Next
End Function

Function getSaveName(strDosNameandPath)
Dim fn
Dim ft
Dim intIncrement

    fn = Left(strDosNameandPath, InStrRev(strDosNameandPath, ".") - 1)
    ft = Right(strDosNameandPath, Len(strDosNameandPath) - InStrRev(strDosNameandPath, ".") + 1)
        Do While fso.FileExists(fn & "_" & intIncrement & ft)
            intIncrement = intIncrement + 1
        Loop
        getSaveName = fn & "_" & intIncrement & ft

End Function

Open in new window

0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,

I verified some folders and its subfolders and their were in total more than 260 characters. To be sure I copied these with few mails (short subject) to a pst file and ran again the script and I got same error message :(.

K rgs
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Your original request was to copy the folder structure ... if the folder structure is too long then you're going to have to compromise in order to meet the DOS limits

Chris
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,

no problem at all :). You helped us al lot with your code.
At this moment I couldn't  test the public folders to copy the folder structure. Tomorrow I will test it.

Happy easter.
0
 

Author Comment

by:DigitBoy
Comment Utility
Hi Chris,


I've made a new question "http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/Q_27667238.html" for long characters in outlook.

Is there any possibility to helps us further please? We know that we are asking so much from you. Our appologize for that.

K rgs
0
 

Author Closing Comment

by:DigitBoy
Comment Utility
The code works very well to export selected folder, but for 2 error message I've got I will create another Questions.

Excellent support from Chris and superb coding skills.
0

Featured Post

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.

Join & Write a Comment

Find out how to use dynamic social media in email signatures with this top 10 DOs & DON’Ts.
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…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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…

728 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

10 Experts available now in Live!

Get 1:1 Help Now