Saving e-mail messages to folder

[Gil]

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

[gmayor]

The following, versions of which I have posted before, will save selected messages as text files to a folder (including a network folder) in the format
yyyymmdd HH.MM" SenderName - Subject.msg.

By including the time. you minimise the number of duplicated files produced (no files are overwritten), but you can remove the time from the fName definitions if you wish.

You will need to change the domain name to your own domain name in order to save messages that you have sent.



Option Explicit

Sub SaveSelectedMessages()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves the currently selected messages
Dim sPath As String
Dim olItem As MailItem
sPath = BrowseForFolder
If sPath = "" Then
Beep
GoTo lbl_Exit
End If
Do Until Right(sPath, 1) = Chr(92)
sPath = sPath & Chr(92)
Loop
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
SaveItem olItem, sPath
End If
Next olItem
lbl_Exit:
Set olItem = Nothing
Exit Sub
End Sub


Private Sub SaveItem(olItem As MailItem, strPath As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
'The main macro called by the above macros.
Dim fname As String
If olItem.sender Like "*@gmayor.com" Then 'Your domain
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(92), "-")
fname = Replace(fname, Chr(124), "-")
On Error GoTo err_Handler
SaveUnique olItem, strPath, fname
lbl_Exit:
Exit Sub
err_Handler:
WriteToLog strPath & "Error Log.txt", strPath & fname
Err.Clear
GoTo lbl_Exit
End Sub


Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While FSO.FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function


Function BrowseForFolder() As String
Dim FSO As Object
Set FSO = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0)
On Error Resume Next
BrowseForFolder = FSO.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
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function

[Gil]

Hello gmayor,
Thank you for your reply which I am currently trying to test. I must warn you that I am not a programmer so if my questions sound daft then I apologise in advance.
I am trying to run the code but am getting an error


err_Handler:
WriteToLog strPath & "Error Log.txt", strPath & fname
Err.Clear

WriteToLog is highlighted

A message pops up saying "Compile error: Sub or function not defined"

Thanks Gil

[gmayor]

Oops - sorry about that, it was part of a larger project that included an error log and I forgot to delete the line :eek:
Simply delete the WriteToLog line.

[Gil]

Hello gmayor, That tweek worked and all seems to be working ok. Is there a limit the code can handle in one session. Otherwise thank you for your help.

[gmayor]

If the process appears to hang when handling large numbers of messages add the line DoEvents before the line Next olItem otherwise have you had a problem that reflects a limit?


For Each olItem In Application.ActiveExplorer.Selection If olItem.Class = OlObjectClass.olMail Then
SaveItem olItem, sPath
End If
DoEvents
Next olItem

[Gil]

Hello gmayor, I was just curious about limits. I have been running it with no problems. The most I have done so far is 57 which took about 5-10 seconds. Once again thank you for your help and I will close the thread as complete.