Mit Excel einen Termin im freigegebenen Kalender eines anderen Benutzer (nicht Standardkalender) auslesen

Hallo,
ich könnte ein bisschen Hilfe benötigen, da ich mit der Lösung nicht weiterkomme und mit VBA noch nicht wirklich viel zu tun habe

Mit dem folgenden Code kann ich bestimmte Termine in meinem persönlichen Outlook-Kalender auslesen und in der UserForm anzeigen lassen.

Was muss ich wie ändern, dass es auch auf einen freigegebenen Kalender (strName) klappt?
Outlook in Exchange-Umgebung

Vielen Dank für eure Hilfe.
Joachim36

Private Sub CommandButton1_Click()

    Dim objApp As Outlook.Application
    Dim objTermin As Object
    Dim finden As String
    Dim strName As String
    Dim i As Long

    On Error Resume Next
     
    ' ### freigegebener Kalender in Outlook angeben ###  
    strName = "kurs"  

    Set objApp = CreateObject("Outlook.Application")  

    finden = Me.TextBox1.Value
    i = 0
    
    For Each objTermin In objApp.GetNamespace("MAPI").GetDefaultFolder(9).Items  
        If finden <> "" Then  
            If InStr(objTermin.Subject, finden) > 0 Then
                With objTermin
                    Me.TextBox1.Value = .Subject
                    Me.TextBox6.Value = .Location
                    Me.TextBox3.Value = Format(.Start, "dd.mm.yyyy")  
                    Me.TextBox4.Value = Format(.Start, "hh:mm")  
                    Me.TextBox5.Value = Format(.End, "hh:mm")  
                    Me.TextBox2.Value = .Body
                    
                    i = i + 1
                End With
            End If
        Else
            MsgBox "Im Suchfeld steht nichts", , "Achtung"  
            Exit Sub
        End If
    Next
    
    If i = 0 Then
        MsgBox "Es wurde im Kalender " & Chr(34) & strName & Chr(34) & " kein Eintrag gefunden.", , "Hinweis"  
    
        'Alle Felder löschen  
        With Me
            'alle TextBoxen Inhalt leeren  
            For i = 1 To 6
                .Controls("TextBox" & i).Value = ""  
            Next i
        End With
    End If

End Sub

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 61366301062

Url: https://administrator.de/contentid/61366301062

Ausgedruckt am: 23.11.2024 um 22:11 Uhr

2 Kommentare

Neuester Kommentar

Namespace.GetSharedDefaultFolder Methode

' ....  
Set myRecipient = objApp.GetNamespace("MAPI").CreateRecipient("Max Muster")  
myRecipient.Resolve
if not myrecipient.resolved then
    msgbox "User gibbed ned", vbExclamation  
    Exit sub
End if
 For Each objTermin In objApp.GetNamespace("MAPI").GetSharedDefaultFolder(myRecipient, olFolderCalendar).Items  
' ....  

Hallo,
so habe ich das jetzt gelöst. Funktioniert auch super.
Danke für den Hinweis mit Namespace.GesSharedDefaultFolder.

Private Sub CommandButton1_Click()

    Dim objApp As Outlook.Application
    Dim objTermin As Object

    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objDummy As Outlook.MailItem
    Dim objRecip As Outlook.Recipient

    Dim finden As String
    Dim strName As String

    Dim i As Long

    On Error Resume Next
     
    ' ### freigegebener Kalender in Outlook angeben ###  
    strName = "kurs"  

    Set objApp = CreateObject("Outlook.Application")  
    Set objNS = objApp.GetNamespace("MAPI")  
    Set objDummy = objApp.CreateItem(olMailItem)
    Set objRecip = objDummy.Recipients.Add(strName)

    objRecip.Resolve

    finden = Me.TextBox1.Value
    i = 0
    
    For Each objTermin In objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar).Items
        If finden <> "" Then  
            If InStr(objTermin.Subject, finden) > 0 Then
                With objTermin
                    Me.TextBox1.Value = .Subject
                    Me.TextBox6.Value = .Location
                    Me.TextBox3.Value = Format(.Start, "dd.mm.yyyy")  
                    Me.TextBox4.Value = Format(.Start, "hh:mm")  
                    Me.TextBox5.Value = Format(.End, "hh:mm")  
                    Me.TextBox2.Value = .Body
                    
                    i = i + 1
                End With
            End If
        Else
            MsgBox "Im Suchfeld steht nichts", , "Achtung"  
            Exit Sub
        End If
    Next
    
    If i = 0 Then
        MsgBox "Es wurde im Kalender " & Chr(34) & strName & Chr(34) & " kein Eintrag gefunden.", , "Hinweis"  
    
        'Alle Felder löschen  
        With Me
            'alle TextBoxen Inhalt leeren  
            For i = 1 To 6
                .Controls("TextBox" & i).Value = ""  
            Next i
        End With
    End If

End Sub