Hi helpmij,
Ik zit vast met mijn code in VBA waar ik de outlook gegevens naar excel wil krijgen, maar waar ik niet de subfolders meekrijg.
Doel:
Een overzicht van mails van mailboxen en subfolder (level1) in scope in een excel, waarbij subfolder level 2 indien aanwezig, als extra veld teruggekoppeld moet worden. Additioneel: ik heb ook mails die alleen in de mailbox staan en niet in een subfolder
Waar ik vast loop:
Ik heb meerdere codes gezien voor level 1 en 2 maar geen idee hoe die in mijn code in te passen mbt het opvragen wat in scope is etc. Level0 werkt naar behoren.
Btw de excel zelf is niet bijster informatie om hier te delen. Er zit namelijk allen in B1 een datum invoerveld in
Ik zit vast met mijn code in VBA waar ik de outlook gegevens naar excel wil krijgen, maar waar ik niet de subfolders meekrijg.
Doel:
Een overzicht van mails van mailboxen en subfolder (level1) in scope in een excel, waarbij subfolder level 2 indien aanwezig, als extra veld teruggekoppeld moet worden. Additioneel: ik heb ook mails die alleen in de mailbox staan en niet in een subfolder
Waar ik vast loop:
Ik heb meerdere codes gezien voor level 1 en 2 maar geen idee hoe die in mijn code in te passen mbt het opvragen wat in scope is etc. Level0 werkt naar behoren.
Code:
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Object
Dim i As Integer
Dim olDict As Dictionary
Set olDict = New Scripting.Dictionary
Dim olDict2 As Dictionary
Set olDict2 = New Scripting.Dictionary
Set OutlookApp = New Outlook.Application
LastRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row
' let the user choose which account to use
Set myAccounts = OutlookApp.GetNamespace("MAPI").Stores
'myAccounts.AddItemOutlookNamespace.GetDefaultFolder (olFolderInbox)
For i = 1 To myAccounts.Count
res = MsgBox(myAccounts.Item(i).DisplayName & "?", vbYesNo)
If res = vbYes Then
Set myInbox = myAccounts.Item(i).GetDefaultFolder(olFolderInbox)
Exit For
End If
Next
If myInbox Is Nothing Then Exit Sub ' avoid error if no account is chosen
Dim key As Range: Set key = Sheets(1).Range("A4")
While Not IsEmpty(key)
If olDict2.Exists(key.Value) Then
Set olDict2(key.Value) = olDict2(key.Value) + key.Offset(ColumnOffset:=2)
Else
olDict2.Add key.Value, key.Offset(ColumnOffset:=2)
End If
Set key = key.Offset(RowOffset:=1)
Wend
'To access a subfolder (level-1) or a subfolder (level-2). Code found online, not sure how to use it in the box to collect input
'For Each Folder In Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders
' If VBA.UCase(Folder.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then GoTo Label_Folder_Found
' For Each sFolders In Folder.Folders
' If VBA.UCase(sFolders.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then
' Set Folder = sFolders
' GoTo Label_Folder_Found
' End If
' Next sFolders
' Next Folder
For Each OutlookMail2 In myInbox.Items
If IsIn(Left(OutlookMail2.Subject, 4), "FW: ,RE: ") Then
OutlookMail2.Subject = Mid(OutlookMail2.Subject, 5)
End If
If olDict.Exists(OutlookMail2.Subject & OutlookMail2.SenderName) Then
If OutlookMail2.ReceivedTime < olDict(OutlookMail2.Subject & OutlookMail2.SenderName) Then
Set olDict(OutlookMail2.Subject & OutlookMail2.SenderName) = OutlookMail2.ReceivedTime
End If
Else:
olDict.Add OutlookMail2.Subject & OutlookMail2.SenderName, OutlookMail2.ReceivedTime
End If
Next OutlookMail2
i = 1
For Each OutlookMail In myInbox.Items
If IsIn(Left(OutlookMail.Subject, 4), "FW: ,RE: ") Then
OutlookMail.Subject = Mid(OutlookMail.Subject, 5)
End If
If TypeName(OutlookMail) = "MailItem" And OutlookMail.ReceivedTime >= Range("From_date").Value Then
If olDict.Exists(OutlookMail.Subject & OutlookMail.SenderName) And Not olDict2.Exists(OutlookMail.Subject & OutlookMail.SenderName) Then
'if the subject exists test to see which message is newer
If OutlookMail.ReceivedTime = olDict(OutlookMail.Subject & OutlookMail.SenderName) Then
Range("A" & LastRow).Offset(i, 0).Value = OutlookMail.Subject & OutlookMail.SenderName
Range("B" & LastRow).Offset(i, 0).Value = OutlookMail.Subject
Range("C" & LastRow).Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("D" & LastRow).Offset(i, 0).Value = OutlookMail.SenderName
Range("E" & LastRow).Offset(i, 0).Value = OutlookMail.Body
Range("F" & LastRow).Offset(i, 0).Value = OutlookMail.Categories
i = i + 1
End If
End If
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
Set olDict = Nothing
End Sub
'
Btw de excel zelf is niet bijster informatie om hier te delen. Er zit namelijk allen in B1 een datum invoerveld in
Laatst bewerkt: