Dim subfolderInbox As Outlook.MAPIFolder
Messages By Store (not PST path)
Private Sub getOutlookMailByStore(sStore As String)
Dim olApp As Outlook.Application = Nothing
Dim subfolderInbox As Outlook.MAPIFolder = Nothing
Dim output As String = String.Empty
Dim olNameSpace As Outlook.NameSpace = Nothing
'create new instance of Outlook.Application
olApp = New Outlook.Application()
'set olNameSpace to MAPI namespace
olNameSpace = olApp.GetNamespace("MAPI")
' TODO: Replace the "YourValidProfile"
' and "myPassword" with Missing.Value
' if you want to log on with the default profile.
olNameSpace.Logon("Outhlook", , True, True)
olNameSpace.Logon()
subfolderInbox = CreateInboxSubFolder(olApp, "archive2")
'used for removing stores that were
'added using 'AddStore'
Dim pstDictionary As New Dictionary(Of String, String)
'For Each pst In pstList
'add pst file to default profile
'olNameSpace.AddStore(pst)
'get pst name
'add to pstDictionary
'Dim pstName As String = olNameSpace.Folders.GetLast().Name
If Not pstDictionary.ContainsKey(sStore) Then
pstDictionary.Add(sStore, Nothing)
End If
'Next
'CreateInboxSubFolder(olApp, "Hello World")
'loop through stores
'It is necessary to loop from count
'to 1 using a decrement
'because Stores.Count is decremented
'whenever(RemoveStore) is called.
'For Each' can't be used for this reason.
For i As Integer = olNameSpace.Stores.Count To 1 Step -1
'Dim oStore As Outlook.Store = olNameSpace.Session.Stores(i)
Dim oStore As Outlook.Store = olNameSpace.Stores(i)
'Try
'Dim sStoreText As String = ""
'sStoreText = pstDictionary.Item(oStore.DisplayName.ToString).ToString
If pstDictionary.ContainsKey(oStore.DisplayName.ToString) Then
'.Find(Function(value As String) Split(value, "||")(0) = Split(sLine, "||")(0))
Debug.Print("oStore: " & oStore.DisplayName.ToString)
'root folder for store
Dim rootFolder As Outlook.MAPIFolder = oStore.GetRootFolder()
'folders for store
Dim subFolders As Outlook.Folders = rootFolder.Folders
'loop through all folders
For Each oFolder As Outlook.Folder In subFolders
'get folder items
'Application.DoEvents()
'TextBox1.AppendText(" Folder: " + oFolder.Name.ToString & vbCrLf)
'Debug.Print(" Folder: " + subFolders.Name.ToString & vbCrLf)
'funRecurse(oFolder, oStore, 0, olApp)
oFolder.CopyTo(subfolderInbox)
'Dim oItems As Outlook.Items = oFolder.Items
'search through each email
'For Each email As Object In oItems
' 'make sure item is a mail item,
' 'not a meeting request
' If email.MessageClass = "IPM.Note" Then
' If TypeOf email Is Microsoft.Office.Interop.Outlook.MailItem Then
' output += "oStore: " + oStore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & System.Environment.NewLine
' TextBox1.AppendText(" oStore: " + oStore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & vbCrLf)
' Debug.Print((" oStore: " + oStore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & vbCrLf))
' End If
' End If
'Next
Next
'remove store that was added above
'If pstDictionary.ContainsValue(rootFolder.Name) Then
' olNameSpace.RemoveStore(rootFolder)
'End If
If pstDictionary.ContainsKey(oStore.DisplayName.ToString) Then
' olNameSpace.RemoveStore(oStore)
End If
'If i = pstList.Count - 1 Then Exit For
End If
' Catch
' End Try
Next
'logoff
'olNameSpace.Logoff()
olNameSpace = Nothing
olApp = Nothing
'MessageBox.Show(output)
'TextBox1.Text = output
End Sub
Messages from PST path
Private Sub getOutlookEmailInfo(ByVal pstList As List(Of String))
Dim olApp As Outlook.Application = Nothing
Dim subfolderInbox As Outlook.MAPIFolder = Nothing
Dim output As String = String.Empty
Dim olNameSpace As Outlook.NameSpace = Nothing
'create new instance of Outlook.Application
olApp = New Outlook.Application()
'set olNameSpace to MAPI namespace
olNameSpace = olApp.GetNamespace("MAPI")
'Dim mapiNameSpace As Outlook.NameSpace = olNameSpace
'Dim folderInbox As Outlook.MAPIFolder = mapiNameSpace.GetDefaultFolder(
' Outlook.OlDefaultFolders.olFolderInbox)
'Dim inboxFolders As Outlook.Folders = folderInbox.Folders
' TODO: Replace the "YourValidProfile"
' and "myPassword" with Missing.Value
' if you want to log on with the default profile.
olNameSpace.Logon("Outhlook", "password", True, True)
olNameSpace.Logon()
subfolderInbox = CreateInboxSubFolder(olApp, "Need to put in Unique Folder")
'used for removing stores that were
'added using 'AddStore'
Dim pstDictionary As New Dictionary(Of String, String)
For Each pst In pstList
'add pst file to default profile
olNameSpace.AddStore(pst)
'get pst name
'add to pstDictionary
Dim pstName As String = olNameSpace.Folders.GetLast().Name
If Not pstDictionary.ContainsKey(pstName) Then
pstDictionary.Add(pstName, Nothing)
End If
Next
'CreateInboxSubFolder(olApp, "Hello World")
'loop through stores
'It is necessary to loop from count
'to 1 using a decrement
'because Stores.Count is decremented
'whenever(RemoveStore) is called.
'For Each' can't be used for this reason.
For i As Integer = olNameSpace.Stores.Count To 1 Step -1
'Dim oStore As Outlook.Store = olNameSpace.Session.Stores(i)
Dim oStore As Outlook.Store = olNameSpace.Stores(i)
'Try
'Dim sStoreText As String = ""
'sStoreText = pstDictionary.Item(oStore.DisplayName.ToString).ToString
If pstDictionary.ContainsKey(oStore.DisplayName.ToString) Then
'.Find(Function(value As String) Split(value, "||")(0) = Split(sLine, "||")(0))
Debug.Print("oStore: " & oStore.DisplayName.ToString)
'root folder for store
Dim rootFolder As Outlook.MAPIFolder = oStore.GetRootFolder()
'folders for store
Dim subFolders As Outlook.Folders = rootFolder.Folders
'loop through all folders
For Each oFolder As Outlook.Folder In subFolders
'get folder items
'Application.DoEvents()
'TextBox1.AppendText(" Folder: " + oFolder.Name.ToString & vbCrLf)
'Debug.Print(" Folder: " + subFolders.Name.ToString & vbCrLf)
'funRecurse(oFolder, oStore, 0, olApp)
oFolder.CopyTo(subfolderInbox)
'Dim oItems As Outlook.Items = oFolder.Items
'search through each email
'For Each email As Object In oItems
' 'make sure item is a mail item,
' 'not a meeting request
' If email.MessageClass = "IPM.Note" Then
' If TypeOf email Is Microsoft.Office.Interop.Outlook.MailItem Then
' output += "oStore: " + oStore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & System.Environment.NewLine
' TextBox1.AppendText(" oStore: " + oStore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & vbCrLf)
' Debug.Print((" oStore: " + oStore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & vbCrLf))
' End If
' End If
'Next
Next
'remove store that was added above
'If pstDictionary.ContainsValue(rootFolder.Name) Then
' olNameSpace.RemoveStore(rootFolder)
'End If
If pstDictionary.ContainsKey(oStore.DisplayName.ToString) Then
' olNameSpace.RemoveStore(oStore)
End If
'If i = pstList.Count - 1 Then Exit For
End If
' Catch
' End Try
Next
'logoff
'olNameSpace.Logoff()
olNameSpace = Nothing
olApp = Nothing
'MessageBox.Show(output)
'TextBox1.Text = output
End Sub
Recursion – Not really used
Function funRecurse(oFolder As Outlook.MAPIFolder, ostore As Outlook.Store, iLevel As Integer, olApp As Outlook.Application) As String
Dim output As String = ""
Dim subFolders As Outlook.Folders = oFolder.Folders
Debug.Print("Folder: " & oFolder.Name.ToString)
funDisplayText(oFolder.Name.ToString, iLevel)
'CreateInboxSubFolder(olApp, oFolder.Name.ToString)
For Each oFolder2 As Outlook.MAPIFolder In subFolders
'subfolderInbox = subfolderInbox.Folders.Add(oFolder2.Name.ToString)
oFolder2.CopyTo(subfolderInbox)
funRecurse(oFolder2, ostore, iLevel + 1, olApp)
Next
Dim oItems As Outlook.Items = oFolder.Items
For Each email As Object In oItems
'make sure item is a mail item,
'not a meeting request
If email.MessageClass = "IPM.Note" Then
If TypeOf email Is Microsoft.Office.Interop.Outlook.MailItem Then
output += "oStore: " + ostore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & System.Environment.NewLine
'TextBox1.AppendText(" oStore: " + ostore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & vbCrLf)
Debug.Print((" oStore: " + ostore.DisplayName + " oFolder: " + oFolder.Name + " " + "subject: " & email.Subject & vbCrLf))
'funDisplayText(oFolder.Name, iLevel + 2)
'funDisplayText(email.Subject, iLevel + 10)
End If
End If
Next
Return output
End Function
Function funDisplayText(text As String, iLevel As Integer)
Dim sText As String = ""
For x = 0 To iLevel
sText += " "
Next
TextBox1.AppendText(sText & text & vbCrLf)
End Function
Create a folder under Inbox and return then handle
'https://www.add-in-express.com/creating-addins-blog/2011/08/01/how-to-create-a-new-folder/
Private Function CreateInboxSubFolder(OutlookApp As Outlook.Application, sFolderName As String) As Outlook.MAPIFolder
Dim mapiNameSpace As Outlook.NameSpace = OutlookApp.GetNamespace("MAPI")
Dim folderInbox As Outlook.MAPIFolder = mapiNameSpace.GetDefaultFolder(
Outlook.OlDefaultFolders.olFolderInbox)
Dim inboxFolders As Outlook.Folders = folderInbox.Folders
Dim subfolderInbox As Outlook.MAPIFolder = Nothing
Try
subfolderInbox = inboxFolders.Add(sFolderName.ToString, Outlook.OlDefaultFolders.olFolderInbox)
Catch ex As COMException
Try
subfolderInbox = inboxFolders.Item(sFolderName.ToString)
Return subfolderInbox
Catch
Return Nothing
End Try
If (ex.ErrorCode = -2147352567) Then
' Cannot create the folder.
'System.Windows.Forms.MessageBox.Show(ex.Message)
Return Nothing
End If
End Try
'If Not IsNothing(subfolderInbox) Then Marshal.ReleaseComObject(subfolderInbox)
'If Not IsNothing(inboxFolders) Then Marshal.ReleaseComObject(inboxFolders)
'If Not IsNothing(folderInbox) Then Marshal.ReleaseComObject(folderInbox)
'If Not IsNothing(mapiNameSpace) Then Marshal.ReleaseComObject(mapiNameSpace)
Return subfolderInbox
End Function