Skip to content

Instantly share code, notes, and snippets.

@AntonGoedecke AntonGoedecke/EMailArchiver Secret
Created Jan 9, 2019

Embed
What would you like to do?
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.