Hi guys,
I'm fairly new to Outlook VBA programming so I'm in a bit of a fix. I've been trying to find a macro that can automatically save the emails in my inbox folder to another folder that i created on my hard drive named 'Documents\Outlook_Mail\Data' as text files so that I can import them into a database. I want to save the body part of the emails, not the attachments.
I scoured the net and found this macro but it keeps sending me the following error: "This folder doesn't exist". I guess problem is how I've set the object folder.
Sub MoveSelectedMessagesToFolder()
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
' Select your destination folder
' Assume this is a mail folder
Set objFolder = GetFolder("C:\Users\Agnes\Documents\Outlook_Mail\Data")
If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "Invalid Folder"
End If
If Application.ActiveExplorer.Selection.Count = 0 Then
'Ensures that a message is selected
MsgBox "Nothing selected", vbOKOnly + vbExclamation, "No message selected"
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
End If
End If
Next
Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub
Public Function GetFolder(StrFolderPath As String) As MAPIFolder
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error Resume Next
StrFolderPath = Replace(StrFolderPath, "/", "\")
arrFolders() = Split(StrFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Could anyone assist me with this code? I would highly appreciate your assistance. Or if possible, help me with another piece of code that can function in the way specified. Thanks in advance
Bookmarks