Save Outlook Emails To Hard Drive

[g8r777]

Does anyone have a macro that will save outlook emails from a specified folder in outlook to a specified folder on the hard drive? I have a tried a macro listed in the following thread:

vbaexpress.com/kb/getarticle.php?kb_id=875

Everytime I try to run this macro, however, I get a run-time error '76' path not found.

When I run the debugger it highlights the line:
FSO.CreateFolder (StrFolderPath).

Can anyone proposed a fix for this error or a whole different macro that will accomplish the same goal.

Thank you,
Brian

[ianc153]

Hi

Newbie here and completely new to this vba stuff (so simple language please!!)

I too would like a fix for this macro as i get the same run-time error as the op.

Thanks

Ian

[ianc153]

Can anybody help?

[Qubit]

Attached is a quick'n'dirty MDB file containing an Extract Email form.

The code is not locked, and not complicated.
Create the destination folder on the drive first.

To name the files to be created, the code uses:
SUBJECT & RECEIVEDTIME, with any non-alpha and non-numeric characters stripped out.

If you want to preserve any characters that don't violate file-naming rules, insert them in the CONSTANT declaration for ALPHANUM.

hope this helps.
Q.

[Blind Tiger]

Does anyone have a macro that will save outlook emails from a specified folder in outlook to a specified folder on the hard drive? I have a tried a macro listed in the following thread:

vbaexpress.com/kb/getarticle.php?kb_id=875

Everytime I try to run this macro, however, I get a run-time error '76' path not found.

When I run the debugger it highlights the line:
FSO.CreateFolder (StrFolderPath).

Can anyone proposed a fix for this error or a whole different macro that will accomplish the same goal.


Thank you,
Brian

The macro runs fine if you use the main folders (Inbox, Sent, Draft, etc) as the source. It will also copy all of the sub folders from those main folders.

[Charlize]

Use
Dir to check for a directory and
MkDir to create a directory instead of the FSO-method.

Charlize

[Ben.Laxton]

Dear Friends,

I am posting this message on this thread as well since it deals directly with the problem trying to solve. If anyone can provide assistance, I would be VERY grateful.

Thanks,

Ben

----------------------------------------------

Dear Friends, :help

I tinkered some more with that code I just asked about (ramserp asked about this too). I have managed to make the code delete all the emails in the main folder (the only folder you can select without getting an error) and all subfolders once it has saved a copy to my chosen destination on the hard drive. This is something that I needed for my task, and I understand if no one else needs that, but I wanted to share it anyway [see code at end of post].

I still cannot figure out why I can't select sub folders. :banghead: When I run the code and select a subfolder, I get the error:

Run-time '76':
Path Not Found

When I choose debug, the code selects the error on the following line:

FSO.CreateFolder (StrFolderPath)

I read in another post (Charlize posted a reply on 05-29-2008 02:34 AM to the Thread: "Save Outlook Emails to Hard Drive" dated 12-07-2006 12:25 PM, started by g8r777) that a solution would be to use the code:

Dir

to check for a directory and the code:

MkDir

to create a directory instead of the FSO-method (from what I can tell, FSO is FileSystemObject).

Being a newbie to VBA, I am trying to make this work and I have NO idea :think: how to incorporate that into the existing code (does this replace FSO?). I tried deleting the FSO lines (note my comments next to those lines in the code) and the code runs AND it allows me to select sub folders AND it deletes my emails (like I programmed it to do). HOWEVER, I have NO idea where the emails go on my hard drive after that - they do not go to the folder I have specified.:dunno

That is as far as I have come thus far - if anyone could please help : pray2: me, I will be eternally grateful. I am continuing to tinker and if I find a solution I would be happy to share it with you all.

Drifting on the 'plains but still searching,

Ben

My new code (that deletes all emails in the main and sub folders):


Option Explicit

Sub SaveMainEmailFolderToHardDrive()

Dim i As Long
Dim j As Long
Dim n As Long
Dim z As Long 'New line of code
Dim iItem As Long 'New line added from other code
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String 'New line added from other code
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As Folder 'Modifed code - was MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If

Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then 'Tried to Delete Code:
FSO.CreateFolder (StrFolderPath) 'Tried to Delete Code:
End If 'Tried to Delete Code:

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime) 'Modified Code: replaced mItem with .Item(j)
StrSubject = mItem.Subject 'Modified Code: replaced mItem with .Item(j)
StrWho = mItem.SenderName 'New Code
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3 'Modified Code: replaced mItem with .Item(j)
mItem.Delete 'New Code
Next j
End With 'New code added in conjunction with With code above in j
'Removed Code: On Error GoTo 0
'Former location of Next i code

'Copied code from above with "z" for reference - want access to subfolders only
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For z = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(z)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrWho = mItem.SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
mItem.Delete
Next z
'Removed Code: On Error GoTo 0
End With 'New code added in conjunction with With code above in n
Next i 'Code moved from above
ExitSub:

End Sub

Function StripIllegalChar(StrInput)

Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:

Set RegX = Nothing

End Function


Function ArrangedDate(StrDateInput)

Dim StrFullDate As String
Dim StrFullTime As String
Dim StrAMPM As String
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object

Set RegX = CreateObject("vbscript.regexp")

If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If

StrFullDate = Left(StrDateInput, 10)

If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If

StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")

If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If

StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")

ExitFunction:

Set RegX = Nothing

End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder As MAPIFolder

Folders.Add Fld.folderpath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub


Function BrowseForFolder(Optional OpenAt As String) As String

Dim ShellApp As Object

Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select

ExitFunction:

Set ShellApp = Nothing

End Function

[Tommy-boy]

...
I still cannot figure out why I can't select sub folders. :banghead: When I run the code and select a subfolder, I get the error:

Run-time '76':
Path Not Found

When I choose debug, the code selects the error on the following line:

FSO.CreateFolder (StrFolderPath)

I read in another post (Charlize posted a reply on 05-29-2008 02:34 AM to the Thread: "Save Outlook Emails to Hard Drive" dated 12-07-2006 12:25 PM, started by g8r777) that a solution would be to use the code:

Dir

to check for a directory and the code:

MkDir

to create a directory instead of the FSO-method (from what I can tell, FSO is FileSystemObject).

Being a newbie to VBA, I am trying to make this work and I have NO idea :think: how to incorporate that into the existing code (does this replace FSO?). I tried deleting the FSO lines (note my comments next to those lines in the code) and the code runs AND it allows me to select sub folders AND it deletes my emails (like I programmed it to do). HOWEVER, I have NO idea where the emails go on my hard drive after that - they do not go to the folder I have specified.:dunno

That is as far as I have come thus far - if anyone could please help : pray2: me, I will be eternally grateful. I am continuing to tinker and if I find a solution I would be happy to share it with you all.

Drifting on the 'plains but still searching,

Ben


I know this is an old thread, but thought this might help people using this macro. I just copied the original code and used it successfully. The reason for the Error 76 and the break at this part of the code:

If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

when you select a subfolder is as follows: StrFolderPath will hold a value that is something like this

"c:\Inbox\Folder 1\Folder 2\"

If the location on c: doesn't contain folders for Inbox, Folder 1, and Folder 2 - that FSO line of the code will try to create it. Problem is, you can't create a folder and subfolder with one FSO command. The inbox folder would need to be created first, then Folder 1, then Folder 2.

The easy way around this is to go into windows explorer and manually create the folders and subfolders prior to running the macro.

I'm sure there's a slick way to do this in VBA, but I'm not good enough to quickly figure it out for this piece of code.

-Tom

[Sunnyp]

Hi g8r777,
Has this issue been solved finally ? If yes, can you advise which post ?

S.

[Charlize]

Hi g8r777,
Has this issue been solved finally ? If yes, can you advise which post ?

S.

Sub check_dir()
'directory in the loop
Dim curdir As String
'parts of the directory
Dim partdir As Long
'the path that you want to check
Dim mypath As String
'declare the path so if inbox has subfolders in subfolders you past
'the whole thing in mypath
mypath = "C:\BACKUPMAIL\TEST\SUBTEST"
'check if the end directory exists
'if 0 then it doesn't exists
If Len(Dir(mypath, vbDirectory)) = 0 Then
MsgBox "Code to create directory."
'starting point, probably c:
'0 is first element in the array of elements when using split
'with separator \
curdir = Split(mypath, "\")(0)
'loop through all the parts of the path using \ as separator
For partdir = LBound(Split(mypath, "\")) To UBound(Split(mypath, "\")) - 1
'define curdir = c: and 2nd element in array (+ 1) since we already got c: which
'was stored in 0 position in this array.
'0 + 1 gives 1 which is c:\BACKUPMAIL if thisworkbook was saved on the c-drive
curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
'check if directory exists, if 0 then create
If Len(Dir(curdir, vbDirectory)) = 0 Then
MsgBox curdir & vbCrLf & "will be created."
MkDir curdir
Else
MsgBox curdir & vbCrLf & "exists."
End If
Next partdir
Else
MsgBox "Directory is present."
End If
End Sub
Maybe this can get you going ...
Charlize

[Charlize]

This code will create the necessary directories for 1 level deep of all the folders that reside in your email account when using outlook on your computer. There is no check if the folder contains email items or calendaritems or contactitems or other stuff. It just creates the directories and trying to prevent errors in the naming of those directories. Use at your own risk :

Sub check_dir()'*** handlers for folders - inbox level + 1 deeper level
Dim NS As Outlook.NameSpace
'the default folder of inbox
Dim myfolder As Outlook.Folder
'subfolder of inbox and all the subfolders
'of the folders that are on the same level as inboxfolder
Dim mysubfolder As Outlook.Folder
Set NS = Application.GetNamespace("MAPI")
'Get the default inboxfolder
Set myfolder = NS.GetDefaultFolder(olFolderInbox)


'*** handlers for directory management
Dim curdir As String
'parts of the directory
Dim partdir As Long
'the path that you want to check
Dim mypath As String


'*** handlers for naming directories
'*** and stripping illegal characters
Dim sreplace As String, mychar As Variant, myfile As String


'replacing illegal characters for directories with something else
sreplace = "_"


'*** the folders on the same level as inbox
For Each mysubfolder In myfolder.Parent.Folders
'c:\backupmail is where inbox directory will come and all folders
'that are on the same level as inboxfolder
mypath = "C:\BACKUPMAIL\" & mysubfolder.Name
'check if the end directory exists
'if 0 then it doesn't exists
If Len(Dir(mypath, vbDirectory)) = 0 Then
'starting point, probably c:
'0 is first element in the array of elements when using split
'with separator \
curdir = Split(mypath, "\")(0)
'loop through all the parts of the path using \ as separator
For partdir = LBound(Split(mypath, "\")) To UBound(Split(mypath, "\")) - 1
'define curdir = c: and 2nd element in array (+ 1) since we already got c: which
'was stored in 0 position in this array.
'0 + 1 gives 1 which is the first folder for the path
'check if directory exists, if 0 then create
If Len(Dir(curdir & "\" & Split(mypath, "\")(partdir + 1), vbDirectory)) = 0 Then
myfile = Split(mypath, "\")(partdir + 1)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
myfile = Replace(myfile, mychar, sreplace)
Next mychar
curdir = curdir & "\" & myfile
'create your directory
MkDir curdir
Else
'adapt the directory in the loop until you need to create
'a new one
curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
End If
Next partdir
End If
Next mysubfolder


'*** This is de part where the subfolders of inbox folder will be created as directories
'*** or any subfolder of the folder that is on the same level as the inbox folder
For Each mysubfolder In myfolder.Folders
'declare the path so if inbox has subfolders in subfolders you past
'the whole thing in mypath. I only used ONE more folder in inbox
'c:\backupmail is where inbox directory will come and
mypath = "C:\BACKUPMAIL\" & myfolder.Name & "\" & mysubfolder.Name
'check if the end directory exists
'if 0 then it doesn't exists
If Len(Dir(mypath, vbDirectory)) = 0 Then
'starting point, probably c:
'0 is first element in the array of elements when using split
'with separator \
curdir = Split(mypath, "\")(0)
'loop through all the parts of the path using \ as separator
For partdir = LBound(Split(mypath, "\")) To UBound(Split(mypath, "\")) - 1
'define curdir = c: and 2nd element in array (+ 1) since we already got c: which
'was stored in 0 position in this array.
'0 + 1 gives 1 which is c:\TEST if thisworkbook was saved on the c-drive
'curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
'check if directory exists, if 0 then create
If Len(Dir(curdir & "\" & Split(mypath, "\")(partdir + 1), vbDirectory)) = 0 Then
myfile = Split(mypath, "\")(partdir + 1)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
myfile = Replace(myfile, mychar, sreplace)
Next mychar
curdir = curdir & "\" & myfile
MkDir curdir
Else
'if the directory exists, we need to adapt the curdir variable that
'holds the path for the folder we are processing. Each time in the loop
'for the folders, curdir has to be build up from zero ie. C:
'after the if that checks the existence of a directory when we declared
'mypath, you'll see that curdir is set to the drive first. ie the first
'element in the array = 0
curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
End If
Next partdir
End If
Next mysubfolder
End Sub
Charlize

[Sunnyp]

can we avoid the error on "FSO.CreateFolder (StrFolderPath)" without creating the same folder structure in advance ?

[Charlize]

can we avoid the error on "FSO.CreateFolder (StrFolderPath)" without creating the same folder structure in advance ?You will have to do the same as I did with Dir and MkDir but instead go one level at a time with the fso.createfolder stuff.

You could use a shell call where you perform an old school dos command that can create a directory of that kind with several levels at once. But you need to know all the folders of the folders to do that. So you have to loop through the folders (of outlook) anyway.


Sub check_with_comspec()
Dim curdir As String
Dim thedir
curdir = "c:\backupmail\inbox\folder1\folder2\folder3"
Set thedir = CreateObject("WScript.Shell")
Call thedir.Run("%COMSPEC% /c mkdir " & curdir, 0, True)
End Sub
change the part of :

If Not FSO.FolderExists(StrFolderPath) Then 'Tried to Delete Code:
FSO.CreateFolder (StrFolderPath) 'Tried to Delete Code:
End If 'Tried to Delete Code:
with

'thedir is used to perform the cmd command in dos language
Dim thedir
Set thedir = CreateObject("WScript.Shell")
If Not FSO.FolderExists(StrFolderPath) Then
'lets hope strfolderpath contains the full path for the item
Call thedir.Run("%COMSPEC% /c mkdir " & StrFolderPath, 0, True)
End If
Charlize

[westconn1]

can we avoid the error onif you want to stick with fso (not necessarily my choice) you can use like

myfolder = "c:\temp\myfolder\test1"
Set fso = CreateObject("scripting.filesystemobject")
If Not fso.FolderExists(myfolder) Then
foldirs = Split(myfolder, "\")
For i = 1 To UBound(foldirs)
If i = 1 Then tmp = foldirs(0) & "\" & foldirs(1) Else tmp = tmp & "\" & foldirs(i)
If Not fso.FolderExists(tmp) Then fso.CreateFolder (tmp)
Next

End Ifyou could also use dir and mkdir in a similar manor, or some API, the fso code is probably most simple and would do the job well

[Bozacke]

Hi This code does exactly what I want, except, I want to save files from a specific Outlook folder as opposed to my IN Box. Would someone be able to point me to what code changes are required to save a specific folder?



This code will create the necessary directories for 1 level deep of all the folders that reside in your email account when using outlook on your computer. There is no check if the folder contains email items or calendaritems or contactitems or other stuff. It just creates the directories and trying to prevent errors in the naming of those directories. Use at your own risk :

Sub check_dir()'*** handlers for folders - inbox level + 1 deeper level
Dim NS As Outlook.NameSpace
'the default folder of inbox
Dim myfolder As Outlook.Folder
'subfolder of inbox and all the subfolders
'of the folders that are on the same level as inboxfolder
Dim mysubfolder As Outlook.Folder
Set NS = Application.GetNamespace("MAPI")
'Get the default inboxfolder
Set myfolder = NS.GetDefaultFolder(olFolderInbox)


'*** handlers for directory management
Dim curdir As String
'parts of the directory
Dim partdir As Long
'the path that you want to check
Dim mypath As String


'*** handlers for naming directories
'*** and stripping illegal characters
Dim sreplace As String, mychar As Variant, myfile As String


'replacing illegal characters for directories with something else
sreplace = "_"


'*** the folders on the same level as inbox
For Each mysubfolder In myfolder.Parent.Folders
'c:\backupmail is where inbox directory will come and all folders
'that are on the same level as inboxfolder
mypath = "C:\BACKUPMAIL\" & mysubfolder.Name
'check if the end directory exists
'if 0 then it doesn't exists
If Len(Dir(mypath, vbDirectory)) = 0 Then
'starting point, probably c:
'0 is first element in the array of elements when using split
'with separator \
curdir = Split(mypath, "\")(0)
'loop through all the parts of the path using \ as separator
For partdir = LBound(Split(mypath, "\")) To UBound(Split(mypath, "\")) - 1
'define curdir = c: and 2nd element in array (+ 1) since we already got c: which
'was stored in 0 position in this array.
'0 + 1 gives 1 which is the first folder for the path
'check if directory exists, if 0 then create
If Len(Dir(curdir & "\" & Split(mypath, "\")(partdir + 1), vbDirectory)) = 0 Then
myfile = Split(mypath, "\")(partdir + 1)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
myfile = Replace(myfile, mychar, sreplace)
Next mychar
curdir = curdir & "\" & myfile
'create your directory
MkDir curdir
Else
'adapt the directory in the loop until you need to create
'a new one
curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
End If
Next partdir
End If
Next mysubfolder


'*** This is de part where the subfolders of inbox folder will be created as directories
'*** or any subfolder of the folder that is on the same level as the inbox folder
For Each mysubfolder In myfolder.Folders
'declare the path so if inbox has subfolders in subfolders you past
'the whole thing in mypath. I only used ONE more folder in inbox
'c:\backupmail is where inbox directory will come and
mypath = "C:\BACKUPMAIL\" & myfolder.Name & "\" & mysubfolder.Name
'check if the end directory exists
'if 0 then it doesn't exists
If Len(Dir(mypath, vbDirectory)) = 0 Then
'starting point, probably c:
'0 is first element in the array of elements when using split
'with separator \
curdir = Split(mypath, "\")(0)
'loop through all the parts of the path using \ as separator
For partdir = LBound(Split(mypath, "\")) To UBound(Split(mypath, "\")) - 1
'define curdir = c: and 2nd element in array (+ 1) since we already got c: which
'was stored in 0 position in this array.
'0 + 1 gives 1 which is c:\TEST if thisworkbook was saved on the c-drive
'curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
'check if directory exists, if 0 then create
If Len(Dir(curdir & "\" & Split(mypath, "\")(partdir + 1), vbDirectory)) = 0 Then
myfile = Split(mypath, "\")(partdir + 1)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
myfile = Replace(myfile, mychar, sreplace)
Next mychar
curdir = curdir & "\" & myfile
MkDir curdir
Else
'if the directory exists, we need to adapt the curdir variable that
'holds the path for the folder we are processing. Each time in the loop
'for the folders, curdir has to be build up from zero ie. C:
'after the if that checks the existence of a directory when we declared
'mypath, you'll see that curdir is set to the drive first. ie the first
'element in the array = 0
curdir = curdir & "\" & Split(mypath, "\")(partdir + 1)
End If
Next partdir
End If
Next mysubfolder
End Sub
Charlize

[westconn1]

Set myfolder = NS.GetDefaultFolder(olFolderInbox)

change this line
without knowing your folder tree and required source folder, we can not provide the correct replacement

[Qualiteeze]

Or you could substitute the Set myfolder with
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim FSO As Object
Dim ChosenFolder As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder

[Charlize]

Set myfolder = Application.Session.PickFoldershould work.

Charlize

Or you could substitute the Set myfolder with
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim FSO As Object
Dim ChosenFolder As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder

[westconn1]

Set myfolder = Application.Session.PickFolder

nice!!