Attempting to archive email files from Outlook

Question

We are trying to pare down the size of our Outlook PSTs, by pulling out no longer relevant emails into various project folders when a project is done. So after realizing the copies you can just pull out of Outlook are virtually unsortable, and do not carry over any of their meta data, I went looking for other solutions. And found a few partial VBA scripts to do it, which i have cobbled together and changed here to try and get what i want.

The routine reads a selection from Outlook, and saves the emails to a provided location with the timestamps and either sender or receiver as needed. Sorted into sub folders. That part seems to work pretty well. But in my test, which I ran on a outlook folder of 238 emails my test-log had 233 entries, but only 231 files were output. Any ideas?

Could it be because the folder is too large? Such that i may need to do it in smaller segments. Or getting ahead of itself, such that i need to add a delay in there somewhere?

Option Explicit

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sRootPath As String
    Dim sPath As String
    Dim dtDate As Date
    Dim sDate As String
    Dim sTime As String
    Dim sName As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim enviro As String
    Dim sUser As String
    Dim fso As Object
    Dim log As Object
    Dim count As Integer

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set log = fso.CreateTextFile("C:\TestLog.txt", True)
    count = 1

    sUser = "UserName"  'During test this was the actual name
    enviro = CStr(Environ("USERPROFILE"))

    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)

    With xlApp.Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sRootPath = .SelectedItems(1)
        End If
    End With

    Set fd = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            sName = RemoveSpecials(sName)
            dtDate = oMail.ReceivedTime
            sFrom = oMail.SenderName
            sTo = oMail.To
            sCC = oMail.CC
            sBCC = oMail.BCC
            sDate = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem)
            sTime = Format(dtDate, "-hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem)
            sPath = sRootPath
            If InStr(sFrom, sUser) > 0 Then
                sName = sDate + sTime + "_" + sUser + "_" + sName + ".msg"
                sPath = sPath + "\To\"
            ElseIf InStr(sCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                    sPath = sPath + "\CC\"
            ElseIf InStr(sBCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                    sPath = sPath + "\BCC\"
            Else
                sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                sPath = sPath + "\Received\"
            End If
            If Dir(sPath, vbDirectory) = "" Then
                MkDir sPath
            End If

            log.WriteLine (CStr(count) + "/" + CStr(ActiveExplorer.Selection.count) + " - " + sPath + sName)
            oMail.SaveAs sPath + sName, olMSG
            count = count + 1
        End If
    Next
End Sub

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+{}@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function

In your selections are you sure they all are `MailItem.MessageClass`? - `"IPM.Note"` look into the items and find out what type or items they are — 0m3r, Feb 13 '18 at 22:43
I believe so but i will check to make sure. I am using one of the project managers email as my test case, so he MIGHT have stuffed a Calendar object or something in there i will give it a check. — Aries7, Feb 13 '18 at 22:46
Also Try using `For i = 1 To ActiveExplorer.Selection.Count` loop — 0m3r, Feb 13 '18 at 22:52
Alright i added a conditional for NOT "IPM.Note". That took care of part of the problem. There were 6 entries that were not IPM.Note, but were actually Calendar appointment messages.That gets me to 233 entries on the log file, and 233 messages in the folder. But the script is still only outputting 231 files. I will see what changing to a for loop does to it. — Aries7, Feb 13 '18 at 23:03
That is what i am begining to think i am checking to see if any generated with the same name — Aries7, Feb 13 '18 at 23:24
We only need the mail archived, i removed the calendar things. — Aries7, Feb 14 '18 at 14:11
Even if not overwriting in this test, you will want to verify if the file already exists. https://stackoverflow.com/questions/16351249/vba-check-if-file-exists/16351888 — niton, Feb 14 '18 at 18:10
Ah yes, in my mind we were always just archiving to empty folders but it may be necessary to do that at some point, i will add that functionality. — Aries7, Feb 14 '18 at 18:17

Aries7 · Answer 1 · 2018-02-15T20:09:17.313

Thanks to 0m3r and niton in the comments above for helping me figure it out. There were some Calendar notes in there which are of course not emails, so they had to be removed, and a couple emails that arrived with the same sender, time and subject so the script was overwriting them.

After this i encountered some problems with getting Outlook on other machines to allow the macro to run. So i went back and rewrote this as VSTO addin for outlook in C#. Only functionality i changed was had the RemoveSpecials check everything except the time, and added a path length check, so things wouldnt generate longer than 260 characters. Which would cause the thing to halt.

This is the VBA script i had before i moved to c#

Option Explicit

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sRootPath As String
    Dim sPath As String
    Dim sLastPath As String
    Dim dtDate As Date
    Dim sDate As String
    Dim sTime As String
    Dim sName As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim sUser As String
    Dim sExtension As String
    Dim iRepeatCount As Integer

    iRepeatCount = 1
    sLastPath = ""
    sExtension = ".msg"

    sUser = "Username"  'During test this was the actual name

    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)

    With xlApp.Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sRootPath = .SelectedItems(1)
        End If
    End With

    Set fd = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    Dim i As Integer

    For i = 1 To ActiveExplorer.Selection.count
        If ActiveExplorer.Selection.Item(i).MessageClass = "IPM.Note" Then
            Set oMail = ActiveExplorer.Selection.Item(i)
            sName = oMail.Subject
            sName = RemoveSpecials(sName)
            dtDate = oMail.ReceivedTime
            sFrom = oMail.SenderName
            sTo = oMail.To
            sCC = oMail.CC
            sBCC = oMail.BCC
            sDate = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem)
            sTime = Format(dtDate, "-hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem)
            sPath = sRootPath
            If InStr(sFrom, sUser) > 0 Then
                sName = sDate + sTime + "_" + sTo + "_" + sName
                sPath = sPath + "\To\"
            ElseIf InStr(sCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName
                    sPath = sPath + "\CC\"
            ElseIf InStr(sBCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName
                    sPath = sPath + "\BCC\"
            Else
                sName = sDate + sTime + "_" + sFrom + "_" + sName
                sPath = sPath + "\Received\"
            End If
            If Dir(sPath, vbDirectory) = "" Then
                MkDir sPath
            End If

            If sPath + sName + sExtension = sLastPath Then
                sName = sName + "(" + CStr(iRepeatCount) + ")"
                iRepeatCount = iRepeatCount + 1
            Else
                iRepeatCount = 1
                sLastPath = sPath + sName + sExtension
            End If
            oMail.SaveAs sPath + sName + sExtension, olMSG            
        End If
    Next
End Sub

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+{}@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function

You will find, in general, you need to put all text used in file names through RemoveSpecials. I found sFrom could contain a non-valid character. — niton, Feb 14 '18 at 18:25

Attempting to archive email files from Outlook

1 Answers1