Saving All Messages to the Hard Drive Using VBA

[paspuggie48]

Hi Forum

I posted a comment and question on the following link to Diane Poremsky >> http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/

Checking this morning though, it is not there anymore. So I will post it again here.

I adore the coding Diane has provided, however I just wanted to know how to re-code it so that the folder (or sub-folder) the email is in is part of the filename. Currently the .msg is saved (or exported) with a prefix of the date and time.

Below is the coding

Sub SaveAllEmails_ProcessAllSubFolders()
Dim StrSavePath As String
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 StrFolder As String
Dim StrSaveFolder As String
Dim StrFolderPath 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

BrowseForFolder StrSavePath

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 = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
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

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(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\\Engineering\Projects\Emails\")
StrSavePath = objFolder.self.Path

On Error Resume Next
On Error GoTo 0

ExitFunction:
Set objShell = Nothing
End Function

Many thanks
Paspuggie48

 

[Michael Bauer]

See where the file name is built by using the strFile variable. The item's folder properties are available via Subfolder.Name or Subfolder.FolderPath

 

[paspuggie48]

Hi Michael

Forgive my ignorance, I'm pretty useless with VBA coding

So, the line code will be this??

StrFile = Subfolder.Name & Subfolder.FolderPath & StrSaveFolder & StrReceived & "_" & StrName & ".msg"

 

[paspuggie48]

Actually, looking at it I don't think it's as easy at that lol

 

[Michael Bauer]

Actually it's very easy. Have you ever seen that the first part of a full file name is the file name itself and then the second part is its directory? No. Certainly you want to write strSaveFolder first, then add some or all of the other parts to it. The last part, of course, must always be the file extension ('.msg' in this case).

 

[paspuggie48]

I think I did it

Many thanks for your help