Save Message Macro

[kenwood85]

Hello,

I'm a complete newbie to VBA, and have done very little in the way of programming since I left High School 12 years ago. I work as a mechanical engineer, and the company I work for has a filing system in place whereby all incoming emails must be filed by the engineers manually in a very specific format. Since time often gets the better of me, I end up with mountains of emails to file, and having to systematically rename them is incredibly tedious and time consuming. I decided to have a bash at putting together a VBA macro which would do the hard work for me by saving selected emails to a destination of my choice on my computer or server. I also thought it would be handy if the macro would change the "date" attribute of the file so that it would possess the actual date that the message was received, thus allowing messages to easily be found by date (and also making it appear that I'm very diligently filing my emails as they arrive rather than waiting to do them in huge batches!).

I've managed to cobble together some code from sources I've found online to do what I want it to do. The script starts off by confirming the number of messages that were selected, so that I could verify that the correct number were actually being saved. I can then select the destination folder for where I would like these saved. The macro formats the file name to DATE RECEIVED + SUBJECT + SENDER + TIME RECEIVED and saves the file. It then executes a command line program called FileTouch which alters the date and time attribute of the file to match the date and time the message was received. It then goes on to the next email and so on.

The macro works well, and the output I get from it is generally correct. The problem seems to be that it will randomly stop running before it completes the entire selection of emails. If I do small batches of 10 emails it works fine, but on large number its doesn't seem to fair so well, ie, I tried it on 2156 and it succeeded in saving and renaming around 1500 before stopping. Also tried it on 1000 emails and it stopped after 300 or so. When it stops there is no error message, it just stops running the macro.

Is this an issue with "my" code or a possible memory problem etc? I had thought it may be the final file name length exceeding the character limit in windows but have since ruled this out.



Public Sub Save_Messages()
Dim dtDate As Date
Dim sName As String
Dim sFile As String
Dim sExt As String
Dim Param As String
Dim newName As String
Dim msg As Variant
Dim strFolderName As String
Dim objSelection As Outlook.Selection
Set objSelection = Application.ActiveExplorer.Selection
MsgBox "Number of selected items: " & objSelection.Count, vbInformation, "Selected Items"
enviro = CStr(Environ("USERPROFILE"))
strFolderName = BrowseForFolder(enviro & "\desktop\")
If Len(strFolderName) > 0 Then
' Do something with the selected folder
For Each msg In Application.ActiveExplorer.Selection
dtDate = msg.ReceivedTime
sName = msg.Subject
sName = sName + " - " + "[" + msg.SenderName + "]"
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
sName = Format(dtDate, "yymmddKT", vbUseSystemDayOfWeek, _
vbUseSystem) & " - " & sName & " - {" & Format(dtDate, "hh.mm", vbUseSystemDayOfWeek, vbUseSystem) & "}"
sName = strFolderName + "\" + sName
'newName = sName + ".msg"
sName = sName + ".msg"
msg.SaveAs sName, olMsg
Call Shell("C:\Email Filing\FileTouch\FileTouch " + "/D " + Format(dtDate, "mm-dd-yyyy ") + "/T " _
+ Format(dtDate, "hh:mm:ss ") + """" & sName & """", 0)
'Name sName As newName
Next
End If
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
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
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function

[gmayor]

You could save yourself some grief by saving the messages as they arrive, but you would have to fix the filepath in code, but with that done you could run a script from a rule.

I have posted below the code I use to save selected batches of messages, modified to include your choice of name string, and your file browser code. I have indicated the changes and omissions needed to use the main code as a rule script. I have added a function to ensure that duplicate filenames are not overwritten.

I do not have FileTouch and cannot test that so I have omitted it. If you are sure that is not the source of the bottleneck then put it back. If you run it as a script from a rule it shouldn't be required.


Option Explicit
'This macro not required for Rule script

Sub Save_Messages()
Dim olItem As MailItem
Dim fPath As String
fPath = BrowseForFolder(CStr(Environ("USERPROFILE")) & "\desktop\") & Chr(92)
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
SaveMessage olItem, fPath
DoEvents
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Sub SaveMessage(olItem As MailItem, fPath As String)
'Sub SaveMessage(olItem As MailItem) 'Alternative for rule script
'Const fPath As String = "C:\Path\" 'Set Path - required for rule script
Dim Fname As String
Dim dtDate As Date
dtDate = olItem.ReceivedTime
Fname = olItem.Subject
Fname = Fname & " - " & "[" & olItem.SenderName + "]"
Fname = Format(dtDate, "yymmddKT", vbUseSystemDayOfWeek, _
vbUseSystem) & " - " & Fname & " - {" & _
Format(dtDate, "hh.mm", vbUseSystemDayOfWeek, vbUseSystem) & "}"
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(124), "-")
SaveUnique olItem, fPath, Fname
lbl_Exit:
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, strPath As String, strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While 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

Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

'Following function not required for Rule script
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
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
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function