save email in Outlook

I need help to change the code to first tell it which folder to save.

I have changed the code to tell it where to save the files.
'StrSavePath = "I:\SavedEmail" '<Not ask you type in code here>

But being that the initial folder is an object. (I don't work well with objects)
I have been unable to change the first step. I need to learn more.

I want my user to click a button and the macro will save all the email from a pre-determand folder to a location I supply.


Please help on this first step. Thanks to anyone!

I have the code:

Sub SaveAllEmails_ProcessAllSubFolders()
        
    'Only does email will not do calendar items
    Dim i               As Long
    Dim j               As Long
    Dim n               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 folder can not be found exit macro
    'If ChosenFolder Is Nothing Then
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
     
    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    
    'StrSavePath = "I:\SavedEmail"   '<Not ask you type in code here>
    
    StrSavePath = BrowseForFolder  ' <Ask for folder>
    
    'if folder can not be found exit macro
    If StrSavePath = "" Then
GoTo ExitSub:
    End If
    
    
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
    'go to function and
    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
        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)
            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

We have moved to Office 2007. The code is written for Outlook 2007, in a module for Outlook.
This was the only VBA Forum that I use because I write a lot of code for Excel. So I started here.

Thanks, Jesseb