EMailArchiver

Attribute VB_Name = "EMailArchiver"
Public Sub ArchiveEMailFolders()

    Dim objNS As Outlook.NameSpace
    Set objNS = GetNamespace("MAPI")
    
    Dim olFolder As Outlook.MAPIFolder
    Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
    
    ArchiveEMails olFolder

    Dim f As Folder
    
    For Each f In olFolder.Folders
    
        ArchiveEMails f
    
    Next f

    Set olFolder = objNS.GetDefaultFolder(olFolderSentMail)
    ArchiveEMails olFolder

End Sub

Public Sub ArchiveEMails(ByRef olFolder As Folder)

    Dim Item As Object
    
    For Each Item In olFolder.Items
    
        If IsEMail(Item) Then
        
            Dim oMail As Outlook.MailItem
            Set oMail = Item
            ArchiveEMail oMail, False
            
        End If
        
    Next

End Sub

Public Sub ArchiveEMail(ByRef oMail As MailItem, prompt As Boolean)

    Dim SentOn As Date
    Dim FileDir As String
    Dim FileName As String
    Dim Suffix As String
            
    If IsEMail(oMail) Then
    
        SentOn = oMail.SentOn
        FileDir = "C:\Mails\" & Format(SentOn, "YYYY") & "\" & Format(SentOn, "MM") & "\" & Format(SentOn, "dd")
        
        
        If Not oMail.Sender Is Nothing Then
            Suffix = Left(oMail.Sender.Name, 5)
        Else
            Suffix = Left(oMail.Subject, 5)
        End If
        
        Suffix = Replace(Suffix, "/", "-")
        Suffix = Replace(Suffix, ":", "-")
        
        FileName = Format(SentOn, "YYYYMMdd(hhmmss)") & Suffix & ".msg"
        
        If Dir(FileDir & "\" & FileName, vbDirectory) = vbNullString Then
            
            MyMkDir FileDir
            oMail.SaveAs (FileDir & "\" & FileName)
            
            If prompt Then
            
                oMail.Subject = "SAVED " & oMail.Subject
                Beep
            
            End If
                        
        End If
        
    Else
    
        MsgBox "Error: No EMail format"
        
    End If
    
End Sub

Public Function IsEMail(Item As Object) As Boolean

    Dim oMail As MailItem
    
    If (TypeOf Item Is MailItem) Then
            
        Set oMail = Item
        
        If oMail.MessageClass = "IPM.Note.EnterpriseVault.Shortcut" Then
            IsEMail = False
        ElseIf oMail.MessageClass = "IPM.Note.Microsoft.Missed.Voice" Then
            IsEMail = False
        ElseIf oMail.MessageClass = "IPM.Note" Then
            IsEMail = True
        ElseIf oMail.MessageClass = "IPM.Note.SMIME.MultipartSigned" Then
            IsEMail = True
        ElseIf oMail.MessageClass = "IPM.Note.SMIME" Then
            IsEMail = True
        ElseIf oMail.MessageClass = "IPM.Note.Rules.OofTemplate.Microsoft" Then
            IsEMail = False
        ElseIf oMail.MessageClass = "IPM.Note.Rules.ReplyTemplate.Microsoft" Then
            IsEMail = False
        ElseIf oMail.MessageClass = "IPM.InfoPathForm.a2f501624e33fdf0$8052f7a53f244ead" Then
            IsEMail = False
        Else
            Debug.Print "Unkonwn MessageClass " & oMail.MessageClass
            IsEMail = False
        End If
        
    Else
        IsEMail = False
    End If

End Function

Public Sub MyMkDir(sPath As String)
    Dim iStart          As Integer
    Dim aDirs           As Variant
    Dim sCurDir         As String
    Dim i               As Integer
 
    If sPath <> "" Then
        aDirs = Split(sPath, "\")
        If Left(sPath, 2) = "\\" Then
            iStart = 3
        Else
            iStart = 1
        End If
 
        sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
 
        For i = iStart To UBound(aDirs)
            sCurDir = sCurDir & aDirs(i) & "\"
            If Dir(sCurDir, vbDirectory) = vbNullString Then
                MkDir sCurDir
            End If
        Next i
    End If
End Sub