Edit VBA code - Save Emails From Outlook To Hard Drive

[dcompto]

Can anyone look at the code, below, and tell me how I should edit it? Googled and found code to "Save Emails From Outlook To Hard Drive". Works great, but I need to make an adjustment. Upon Save, the subfolders are placed outside the parent folder. I need the subfolders to be saved inside the parent folder. I can't figure out where to make the adjustment. I went back to VBAexpress.com where I found the code, but haven't found a way to contact the author.

Sub SaveAllEmails_ProcessAllSubFolders()
     
    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 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
        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

TIA for any help you can provide.

 

[jedraw]

This proc wasn't found

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

 

[yooneek]

For Jed:
Public Function GetFolder(strFolderPath As String) As MAPIFolder
'===================================================
'Sue Mosher
'

http://www.outlookcode.com/d/code/getfolder.htm

' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
' or "Mailbox - User Name\Calendar\My Events"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
Dim j As Long
On Error Resume Next

' just in case the path string uses the wrong
' slash mark
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
' set starting folder and array element
If Left(strFolderPath, 34) = _
"Public Folders\All Public Folders\" Then
Set objFolder = objNS.GetDefaultFolder( _
olPublicFoldersAllPublicFolders)
j = 2
Else
Set objFolder = objNS.Folders.Item(arrFolders(0))
j = 1
End If

If Not objFolder Is Nothing Then
For i = j To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing

End Function

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

dcompto:

1) Just to clean it up, if you are using and If Then to error check and exit the sub then I'd suggest just writing it in a single line:
Change this=
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
To this=
If ChosenFolder Is Nothing Then Exit Sub

Don't need the End If or the Goto. Of course you could integrate the Goto if you were building a full error message for the end.
Like this=
If ChosenFolder Is Nothing Then Goto ExitSub


2) As the code is currently written, it simply loops through all folders, without concern as to parent or pst. You would need to look at sub processing (itterating) down to the sub folder level, creating the parent folders (in Windows) as the process was being done, then you could have it run through the subfolder. After it finished that level, go up on folder then search for the next sub folder.

Esentially it's 2 loops.


Some of this is mine, some I borrowed. It's designed to pull information from a Userform listbox that has all of my custom views and then itterate through all of the folders and apply this view.

Public Sub ChangeView()

Dim lCountOfFound As Long
Dim olStartFolder As Outlook.MAPIFolder
'Dim NewView As String
Dim f As Integer
Dim CurFldr As Folder

Set CurFldr = ActiveExplorer.CurrentFolder

On Error GoTo 0
lCountOfFound = 0

ListViews.Show
On Error GoTo exity
NewView = ListViews.ListBox1.Value

For f = Session.Folders.Count To 1 Step -1
If InStr(1, Session.Folders(f), Session.CurrentUser) = 0 And _
InStr(1, Session.Folders(f), "Mailbox") = 0 And _
InStr(1, Session.Folders(f), "Public") = 0 Then

Set olStartFolder = Session.Folders(f)
If Not (olStartFolder Is Nothing) Then
ChangeViewProcessFolder olStartFolder
End If
End If
Next f

Set ActiveExplorer.CurrentFolder = CurFldr

exity:

End Sub

Function ChangeViewProcessFolder(CurrentFolder As Outlook.MAPIFolder)

On Error GoTo 0

Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim lCountOfFound As Integer

For i = CurrentFolder.Folders.Count To 1 Step -1
Set olTempFolder = CurrentFolder.Folders(i)
Select Case olTempFolder.Name
Case "Deleted Items", "Calendar", "Tasks", "Journal", "RSS Feeds", _
"Contacts", "Notes", "Drafts", "Outbox", "Sent Items"
GoTo next1
End Select

Set ActiveExplorer.CurrentFolder = olTempFolder
ActiveExplorer.CurrentView = NewView

lCountOfFound = lCountOfFound + 1
next1:
Next

For Each olNewFolder In CurrentFolder.Folders
Select Case olNewFolder.Name
Case "Deleted Items", "Calendar", "Tasks", "Journal", "RSS Feeds", _
"Contacts", "Notes", "Drafts", "Outbox", "Sent Items"
GoTo next2
Case Else
ChangeViewProcessFolder olNewFolder
End Select
next2:
Next

End Function






OCD, it’s not obsessive if you can control it…

 

[dcompto]

Thanks for your responses, jedraw and yooneek. I appreciate the feedback and suggestions. I have it working, but I went around in circles so many times, I'm not sure how I fixed it. %-) I'll have to do a line-by-line comparison between the old and new versions in order to tell. After all was said and done, I realize the timestamp of each of the saved MSG files is the Creation Date and Time of the Save instead of the email's Received Date, rendering the macro useless for our purposes. C'est la vie!