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

Please also mark the comments that contributed to the solution of the article

Content-Key: 61366301062

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

Printed on: April 28, 2024 at 00:04 o'clock

2 Comments

Latest comment

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

German solved Question VB for Applications

Hotly discussed

End of availability for classic Teams clientDani