Sub SaveEmails()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim Item As outlook.MailItem
Dim sF As String
sF = "c:\temp\msg\"
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
' Check Inbox for messages and exit if none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Save inbox items as MSG files to sF
For Each Item In Inbox.Items
If TypeName(Item) <> "MailItem" Then GoTo NextItem
Item.SaveAs sF & Replace(Replace(Item.ReceivedTime, "/", "-"), ":", ".") & ".msg", olMSG 'olmsgunicode
'Debug.Print Replace(Replace(Item.ReceivedTime, "/", "-"), ":", ".")
NextItem:
Next Item
End Sub
Sub SaveEmails2()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim Item As outlook.MailItem
Dim sF As String, sInbox As String
sF = "c:\temp\msg\"
sInbox = "\\ken@gmail.com\Car"
Set ns = GetNamespace("MAPI")
'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set Inbox = GetFolderPath(sInbox, outlook.Application)
'Debug.Print Inbox.Name 'Car
' Check Inbox for messages and exit if none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Save inbox items as MSG files to sF
For Each Item In Inbox.Items
If TypeName(Item) <> "MailItem" Then GoTo NextItem
Item.SaveAs sF & Replace(Replace(Item.ReceivedTime, "/", "-"), ":", ".") & ".msg", olMSG 'olmsgunicode
NextItem:
Next Item
MsgBox "Macro has finished."
End Sub
'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As outlook.Application) As outlook.Folder
Dim oFolder As outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function