AW: Outlook Import aus geteiltem fach
13.09.2022 14:59:03
Floboss
Hallo Fennek,
ich habe deinen Code mal reingenommen. Wenn ich den durchlaufen lasse sehe ich nach dem dritten durchlauf der Schleife, das der Benutzer gefunden wird. Und mir wird auch angezeigt das der Benutzer 3 Ordner hat. Nun weiß ich leider immer noch nicht so ganz wie ich das umsetzen soll. Da VBA nicht meine aller beste Seite ist.
Hier noch einmal meinen ganzen Code.
Sub OutlookPosteingang()
'Variablendeklaration
Dim OLF As Outlook.MAPIFolder
Dim AnzEintraege As Integer, i As Integer, Email As Integer
Dim Loletzte As Long
Dim RngZ As Range
Dim RngY As Range
Dim TempStr As String
Worksheets("Mails").Activate
On Error Resume Next
[A1].Value = "Betreff"
[B1].Value = "Datum Uhrzeit"
[C1].Value = "empfangen von"
[D1].Value = "gelesen"
[E1].Value = "Nachricht"
[F1].Value = "Dateianhänge"
Rows(1).Font.Bold = True
Worksheets("Config").Activate
Set OLF = GetObject("", "Outlook.Application") _
.GetNamespace("MAPI").GetDefaultFolder(olExchangeMailbox).Folders("Geteilte Person") '.Parent.Folders(CStr(Range("C3")))
Dim FLD As Folder
For Each FLD In Session.Folders
'Debug.Print FLD.Name, FLD.Store.ExchangeStoreType
If FLD.Store.ExchangeStoreType = olExchangeMailbox Then
Debug.Print FLD.Name, FLD.Items.Count, FLD.Folders.Count, FLD.Folders("Posteingang").Items.Count
End If
' 0: olPrimaryExchangeMailbox
' 1: olExchangeMailbox
' 2: olExchangePublicFolder
' 3: olNotExchange
' 4: olAdditionalExchangeMailbox
Next FLD
'Datenort wechseln
Worksheets("Mails").Activate
'Setzen der Variable -> es sollen alle Nachrichten im Ordner 'Posteingang (olFolderInbox) gezählt werden
AnzEintraege = OLF.Items.Count
'Setzen der Variablen auf '0'
i = 0: Email = 0
'Beginn Schleifendurchlauf (Schleife 1) -> die Variable 'i' läuft solange, wie Anzahl der _
EMails vorhanden sind
While i Anzahl der Anhänge in der EMail
Cells(Email + 1, 6).Value = .Attachments.Count
'Ende der Schleife 2
End With
'Ende der Schleife 1
Wend
'Die Variable muss wieder auf Null gesetzt werden = nothing halt
Set OLF = Nothing
'Die Spalten sollen automatisch in der Breite angeglichen werden
Columns("A:F").AutoFit
'Die Statuszeile wird wieder ausgeschaltet
Application.StatusBar = False
'Kopieren der Emails in andere Tabelle
For Each RngZ In Worksheets("Mails").Range("A1:A9999")
With Worksheets("Aufgaben_Rueckmeldung")
Loletzte = .Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each RngY In .Range("A1:A9999")
If (RngZ.Value = RngY.Value) And (CStr(RngZ.Offset(0, 1).Value) = CStr(RngY.Offset(0, 1).Value)) Then GoTo NextRng:
Next
If RngZ Like "*NR:*" And RngZ .Cells(Loletzte, 1) Then
For i = 0 To 5
TempStr = CStr(RngZ.Offset(0, i).Value)
.Cells(Loletzte, i + 1) = TempStr
Next i
End If
End With
NextRng:
Next
'Datenblatt wechseln
Worksheets("Aufgaben_Rueckmeldung").Activate
'Formel einfügen
Dim Zelle As Range
Dim Nr As Long
For Each Zelle In ActiveSheet.Range("g2:g9999")
Nr = Zelle.Row
Zelle.FormulaLocal = "=TEIL(@A:A;18;5)"
Next Zelle
'Die Exceldatei wird gespeichert
ActiveWorkbook.Saved = True
End Sub
Wobei der obere Teil der ist, der Interessant ist. Quasi will ich in dem "OLF" kein Nothing sehen sondern gerne das Richtige.