VBA pull Outlook Emails by Folder

'Button initiate process

Private Sub Command4_Click()
 Dim Report As String
 Dim Folders As Outlook.Folders
 Dim folder As Outlook.folder
 Dim reply As Integer
 Dim NameSpaceObj As Outlook.Namespace: Set NameSpaceObj = GetNamespace("MAPI")
 Dim BaseFolder As Outlook.MAPIFolder
 Set BaseFolder = NameSpaceObj.GetDefaultFolder(olFolderInbox)
 Dim Item As Object
 Dim FolderIndex() As String



folderType = "Personal"
 
 i = 0
 ReDim FolderIndex(0)
 For Each Item In BaseFolder.Folders
 If TypeOf Item Is Outlook.folder Then
 FolderIndex(i) = Item.Name
 i = i + 1
 ReDim Preserve FolderIndex(i)
 End If
 Next
 
 Dim myUserForm As UserForm1
 Set myUserForm = New UserForm1
 On Error Resume Next

'myUserForm.ListBox1.MultiSelect = 1
 myUserForm.ListBox1.List = FolderIndex
 myUserForm.BaseFolder = ""
 myUserForm.folderType = folderType
 myUserForm.Show
End Sub



'Form

TextBox1

ListBox1



'Form button

Public BaseFolder As String
Public folderType As String

Private Sub SeeSubFolders_Click()
Dim NameSpaceObj As Outlook.Namespace: Set NameSpaceObj = GetNamespace(“MAPI”)
Dim StartFolder As Outlook.MAPIFolder
Dim FolderIndex() As String
If folderType = “Public” Then
Set StartFolder = NameSpaceObj.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Else
Set StartFolder = NameSpaceObj.GetDefaultFolder(olFolderInbox)
End If
i = 0
ReDim FolderIndex(0)
For j = 0 To ListBox1.ListCount – 2
If ListBox1.Selected(j) = True Then
If BaseFolder = “” Then
Set StartFolder = StartFolder.Folders(ListBox1.List(j))
BaseFolder = ListBox1.List(j)
Else
BaseFolder = BaseFolder & “==>” & ListBox1.List(j)
For Each i In Split(BaseFolder, “==>”)
Set StartFolder = StartFolder.Folders(i)
Next
End If
For Each Item In StartFolder.Folders
FolderIndex(i) = Item.Name
i = i + 1
ReDim Preserve FolderIndex(i)
Next
ListBox1.List = FolderIndex
End If
Next
End Sub

Public Sub CheckIfChildren()
Dim NameSpaceObj As Outlook.Namespace
Dim Start_Folder As Outlook.MAPIFolder
Set NameSpaceObj = GetNamespace(“MAPI”)

SeeSubFolders.Enabled = True
For j = 0 To ListBox1.ListCount – 1
If ListBox1.Selected(j) = True Then
If folderType = “Public” Then
Set Start_Folder = NameSpaceObj.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Else
Set Start_Folder = NameSpaceObj.GetDefaultFolder(olFolderInbox)
End If
‘Set StartFolder = NameSpaceObj.GetDefaultFolder(olPublicFoldersAllPublicFolders)

If BaseFolder <> “” Then
For Each i In Split(BaseFolder, “==>”)
Set Start_Folder = Start_Folder.Folders(i)
Next
End If
If Start_Folder.Folders(ListBox1.List(j)).Folders.Count > 0 Then
Else
SeeSubFolders.Enabled = False
End If
End If
Next
End Sub

Private Sub ListBox1_Click()
Call CheckIfChildren
End Sub

Private Sub SubmitForm_Click()
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim TextToWrite As String
Dim Report As String
Dim Folders As Outlook.Folders
Dim folder As Outlook.folder
Dim reply As Integer
Dim j, jj As Long
j = 0
jj = 0
Set objNS = GetNamespace(“MAPI”)
If folderType = “Public” Then
Set objFolder = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Else
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
End If
If BaseFolder <> “” Then
For Each i In Split(BaseFolder, “==>”)
Set objFolder = objFolder.Folders(i)
Next
End If
TextToWrite = “Subject” + “|” + _
“Body” + “|” + _
“FromName” + “|” + _
“ToName” + “|” + _
“CCName” + “|” + _
“BCCName” + “|” + _
“Categories” + “|” + _
“Importance” + “|” + _
“Sensitivity” + “|” + _
“Attachment Name” + “|” + _
“Sent Date” + “|” + _
“Received Date”

For j = 0 To ListBox1.ListCount – 2
If ListBox1.Selected(j) = True Then
Set objFolderTwo = objFolder.Folders(ListBox1.List(j))
For Each Item In objFolderTwo.Items
If TypeOf Item Is Outlook.MailItem Then
Dim currentMail As Outlook.MailItem: Set currentMail = Item
TextToWrite = TextToWrite + vbNewLine + currentMail.Subject
TextToWrite = TextToWrite + “|” + Replace(Replace(currentMail.Body, vbNewLine, “\n”), “|”, ” “)
TextToWrite = TextToWrite + “|” + currentMail.SenderName
TextToWrite = TextToWrite + “|” + currentMail.To
TextToWrite = TextToWrite + “|” + currentMail.CC
TextToWrite = TextToWrite + “|” + currentMail.BCC
TextToWrite = TextToWrite + “|” + currentMail.Categories
TextToWrite = TextToWrite + “|” + CStr(currentMail.Importance)
TextToWrite = TextToWrite + “|” + CStr(currentMail.Sensitivity) + “|”
If currentMail.Attachments.Count > 0 Then
For Each Attachment In currentMail.Attachments
TextToWrite = TextToWrite + Attachment + “, ”
Next
End If
TextToWrite = TextToWrite + “|” + CStr(currentMail.SentOn)
TextToWrite = TextToWrite + “|” + CStr(currentMail.ReceivedTime)
End If
Next
End If

Next j
nameOfFile = “Z:\” & TextBox1.Value & “.csv”
Set fso = CreateObject(“Scripting.FileSystemObject”)
Set out = fso.CreateTextFile(nameOfFile, True, True)
out.WriteLine (TextToWrite)
out.Close
Unload Me
SysCmd acSysCmdRemoveMeter

DoCmd.SetWarnings (warningsOff)
DeleteTblStrSql = “DELETE EmailData.* FROM EmailData;”
DoCmd.RunSQL (DeleteTblStrSql)
DoCmd.TransferText acImportDelim, “Pipe”, “EmailData”, “Z:\” & TextBox1.Value & “.csv”
‘ Print #300, TextToWrite
‘ Close #300
Unload Me
End Sub

Private Sub UserForm_Initialize()
Call CheckIfChildren
End Sub