'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

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




dfagfda

fd
‘Subfolder button

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