Sub EmailExport()
Dim myolApp As Outlook.Application
Dim aItem As Object
Set myolApp = CreateObject("Outlook.Application")
Set mail = myolApp.ActiveExplorer.CurrentFolder
Dim iItemsUpdated As Integer
Dim strTemp As String
Dim strFilenum As String
iItemsUpdated = 0
Dim xItem As Object
Dim xNewSubject As String
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim path As String
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objNS.Folders("SWN")
Set objFolder = objFolder.Folders("SK2") ' parent folder
Debug.Print (objFolder.Name)
' Set objFolder = objFolder.Folders("Test2") ' subfolder.
' Debug.Print (objFolder.Name)
For Each aItem In objFolder.Items
Dim mattcombine, mattyear, mattmonth, mattday As String
Dim i, j As Integer
i = InStr(2, aItem.ReceivedTime, "/")
j = InStr(i + 1, aItem.ReceivedTime, "/")
' MsgBox i & " and " & j
mattyear = Mid(aItem.ReceivedTime, j + 1, 4)
' MsgBox mattyear
mattmonth = Left(aItem.ReceivedTime, i - 1)
If Len(mattmonth) = 1 Then
mattmonth = "0" & mattmonth
End If
' MsgBox mattmonth
mattday = Mid(aItem.ReceivedTime, i + 1, j - i - 1)
' MsgBox mattday
If Len(mattday) = 1 Then
mattday = "0" & mattday
End If
' MsgBox mattyear & "-" & mattmonth & "-" & mattday
mattcombine = mattyear & "-" & mattmonth & "-" & mattday
' MsgBox mattcombine
Dim zachcombine, zachhour, zachminute, zachsecond, zacho As String
Dim z, q As Integer
z = InStr(2, aItem.ReceivedTime, ":")
q = InStr(z + 1, aItem.ReceivedTime, ":")
' MsgBox z & " and " & q
zachhour = Mid(aItem.ReceivedTime, z - 2, 2)
' MsgBox zachhour
Dim hourspace
hourspace = Left(zachhour, 1)
' MsgBox hourspace
If hourspace = " " Then
zachhour = zachhour
Else: zachhour = " " & zachhour
End If
' MsgBox zachhour
zachminute = Mid(aItem.ReceivedTime, z + 1, 2)
' MsgBox zachminute
zachsecond = Mid(aItem.ReceivedTime, q + 1, 2)
' MsgBox zachsecond
zacho = Mid(aItem.ReceivedTime, q + 4, 2)
' MsgBox zacho
zachcombine = zachhour & "-" & zachminute & "-" & zachsecond & " " & zacho
' MsgBox zachcombine
' Removes special characters
Set xMailItem = aItem
With xMailItem
xNewSubject = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(.Subject, "/", ""), ":", ""), ".", ""), "*", "") _
, "|", ""), "", ""), "<", ""), ">", ""), "?", ""), ",", ""), Chr(34), "")
.Subject = xNewSubject
.Save
End With
' Exports
If TypeName(aItem) = "MailItem" Then
' On Error Resume Next ' do not use as errord emails will still be deleted
path = "G:\Special\This_is_a_test_folder123\123\General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg" ' change C:\Users\stuebing_z\Desktop\test2\ to where you want to export emails
' path = "G:\Special\This_is_a_test_folder123\123\General Communication"
' FileName = "General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg"
' aItem.SaveAs path & FileName
aItem.SaveAs (path)
'Debug.Print Item.ConversationTopic
End If
Next
' Deletes messages in folder
total_messages = objFolder.Items.Count
For i = 1 To total_messages
message_index = total_messages - i + 1
Set oMessage = objFolder.Items.Item(message_index)
oMessage.Delete
Set oMessage = Nothing
Next
End Sub
Another possible solution would be to on error move the email to a subfolder in outlook.