Excel VBA Emailzugriff Berechtigunganfrage von Outlook

Option Explicit
Global OLF As Outlook.MAPIFolder
Global arrEmail(), z As Long                        'Array Emails: [Variable](ID, Betreff, Zeitstempel)  
Global EmailSelect As Integer                       'ausgewählte Email  

Sub email_auslesen()
'###################################################################  
'Mit diesem Programm wird der Inhalt einer Email in Excel importiert  
'###################################################################  

Dim OLF As Outlook.MAPIFolder
Dim CountInbox As Integer                           'Anzahl der Elemente Posteingang  
Dim i As Integer                                    'Zähler Schleife Posteingeng auslesen  
Dim Suchtxt As String                               'Identifier der Email  
Dim IDEmailSelect As Integer                        'ID der ausgewählten Email  
Dim arrImport(), y As Long                          'Importarray der Excelliste aus der Email  


'Defaultwerte  
i = 0: z = 0
Suchtxt = "Status Fahrzeuge, offene Punkte"  

'Globale Fehlerbehandlung  
On Error Resume Next


'Setzen der Variable als Outlook Application; Zugriff auf Outlook  
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  


'Anzahl Emails im POSTEINGANG  
CountInbox = OLF.Items.Count


'Emailarray befüllen  
    For i = 1 To CountInbox
        With OLF.Items(i)
            If InStr(1, .Subject, Suchtxt) > 0 Then  'Rückgabewert 0 = false  
                ReDim Preserve arrEmail(0 To CountInbox, 0 To 2)
                arrEmail(z, 0) = i                  'ID  
                arrEmail(z, 1) = .Subject           'Betreff  
                arrEmail(z, 2) = .ReceivedTime      'Empfangen am Datum  
                z = z + 1
            End If
        End With
    Next


'Öffne Popup mit Emailauswahl  
Emailauswahl.Show
'Antwort Email-ID  
IDEmailSelect = arrEmail(EmailSelect, 0)


'Email selekiert  
    With OLF.Items(IDEmailSelect)
    
        '#####################        
        y = 5
        ReDim Preserve arrImport(0 To y, 0 To 2)
        arrImport(1, 2) = .HTMLBody                 'HTML  

        '#####################  
        
    End With

'Durchlauf abgeschlossen  
Set OLF = Nothing
Application.StatusBar = False           'Statuszeile ausschalten  
Erase arrEmail()
End Sub