Archangelos
New Member
- Joined
- Aug 21, 2017
- Messages
- 49
Introduction
Take a look at the following picture.
There are two Outlook data files, their root folders are named “_FMMB” and “_Middle”. Both files have and subfolders and subfolders in subfolders.
A number of emails are moved from Inbox to folder “_Middle\000_Arrive” manually (I prefer it that way).
The code should move all emails from folder “_Middle\000_Arrive” to a folder in either “_FMMB” or “_Middle” based on the email’s subject.
The code
I am a little bit experienced in utilizing VBA in MS Excel but totally newbie when it comes to Outlook. I got a little bit confused with Namespace, MAPI and other stuff.
I searched the Internet and I made my first attempt. I scanned the folder (“_Middle\000_Arrive”), read the subjects of the email and displayed them in a Message Box.
Here is the code, a last step is pending.
Any help would be appreciated.
Take a look at the following picture.
There are two Outlook data files, their root folders are named “_FMMB” and “_Middle”. Both files have and subfolders and subfolders in subfolders.
A number of emails are moved from Inbox to folder “_Middle\000_Arrive” manually (I prefer it that way).
The code should move all emails from folder “_Middle\000_Arrive” to a folder in either “_FMMB” or “_Middle” based on the email’s subject.
The code
I am a little bit experienced in utilizing VBA in MS Excel but totally newbie when it comes to Outlook. I got a little bit confused with Namespace, MAPI and other stuff.
I searched the Internet and I made my first attempt. I scanned the folder (“_Middle\000_Arrive”), read the subjects of the email and displayed them in a Message Box.
Here is the code, a last step is pending.
Code:
'[VBA][KTZ] Archive emails: 001
Sub ArchiveEmails() 'Primary code part from: https://www.encodedna.com/excel/how-to-parse-outlook-emails-and-show-in-excel-worksheet-using-vba.htm
Dim Thema As String
Dim FinalFolder As String
On Error GoTo ErrHandler
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder As Object
Set myFolder = GetFolderPath("_Middle\000_Arrive") '.Items
Dim Item As Object
' LOOP THROUGH EACH ITEMS IN THE FOLDER.
For Each Item In myFolder.Items
If Item.Class = olMail Then
Dim objMail As Outlook.MailItem
Set objMail = Item
'MsgBox objMail.Subject 'SO FAR IT WORKED
Thema = objMail.Subject
End If
Select Case Thema
Case Is >= "modular.xlsm"
FinalFolder = "_Middle\200_Backup\201_Equipment\201-02_Modular"
Case Is >= "matrix.xlsm"
FinalFolder = "_Middle\200_Backup\201_Equipment\201-01_Matrix"
Case Is >= "matrix.vsd"
FinalFolder = "_Middle\200_Backup\201_Equipment\201-01_Matrix"
Case Is >= "ITH.xlsm"
FinalFolder = "_Middle\200_Backup\202_Services\202-01_ITH"
Case Is >= "FLH.xlsm"
FinalFolder = "_Middle\200_Backup\202_Services\202-01_FLH"
Case Is >= "NFL.xlsm"
FinalFolder = "_Middle\200_Backup\202_Services\202-01_NFL"
Case Is >= "issue301.xlsm"
FinalFolder = "_FMMB\300\301"
Case Is >= "issue302.xlsm"
FinalFolder = "_FMMB\300\302"
Case Is >= "issue501.xlsm"
FinalFolder = "_FMMB\500\501"
Case Is >= "issue502.xlsm"
FinalFolder = "_FMMB\500\502"
Case Else
'Nothing to be done
End Select
'HERE SOMETHING IS MISSING
'THE REST OF THE CODE SHOULD MOVE THE EMAILS
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
'https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
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))
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
Any help would be appreciated.