Using this code off your site http://www.vbaexpress.com/kb/getarticle.php?kb_id=875 courtesy of Jacob Hilderbrand I am able to achieve transferring outlook messages to a folder on my PC.

2 things I am having problems with are

1. What do the numbers that are added to the file name mean i.e. -201-02--07-201_00-023-07-2_test1.

test1 is the file name but the macro adds -201-02--07-201_00-023-07-2_. I don't understand what this represents. What do I need to change to just add the date received in dd.mm.yyyy format.

2. I can save the messages locally but not over a network to a NAS.

As an additional thought is it possible to select messages from a folder instead of the whole folder contents.

I have tried deleting various bits but haven't had any success yet. Any help would be appreciated.

Sorry to post the whole script.



Option Explicit 


 
Sub SaveAllEmails_ProcessAllSubFolders()
     
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim k               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    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 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
FSO.CreateFolder (StrFolderPath)
End If


Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
' On Error Resume Next ' <-- I suggest you comment this out when debugging
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)


' StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
' StrFile = Left(StrFile, 256)


StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & ".msg"


k = 0 ' <--- i is already being used
JumpHere:
If Dir(StrFile) = "" Then
mItem.SaveAs StrFile, 3
Else
k = k + 1
StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & k & ".msg"
GoTo JumpHere
End If


mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
     
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