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
