VBA Excel Kalenderauswahl in Outlook

Hallo Leute,


folgendes Problem:

Ich habe eine Geburtstagsliste in Excel, welche ich mit Hilfe von VBA nach Outlook schicke, um dort einen Serientermin zu generieren.


Der VBA Code funktioniert soweit super, nur es wird mir mein Standard Kalender automatisch ausgewählt.

Wie muss ich den Code ändern um einen anderen Kalender auszuwählen?

Der Kalender hat den Namen "Geburtstage". Er befindet sich in der selben Kalendergruppe wie mein Standardkalender.


Hier der aktuelle Code:

Option Explicit


Function AppointmentExists(ByVal objOutlook As Object, ByVal datStart As Date, ByVal strSubject As String) As Boolean
Dim objMapiFolder As Object
Dim objCalendarItem As Object
AppointmentExists = True
Set objMapiFolder = objOutlook.GetNamespace("MAPI").Session.PickFolder
For Each objCalendarItem In objMapiFolder.Items
If objCalendarItem.Subject = strSubject And _
Month(objCalendarItem.Start) = Month(datStart) And _
Day(objCalendarItem.Start) = Day(datStart) Then
Exit Function
End If
Next objCalendarItem
AppointmentExists = False
End Function


Private Sub Termin_nach_Outlook_Click()
Dim OutApp As Object, apptOutApp As Object
Dim OutPattern As RecurrencePattern
Dim objOutlook As Object
Dim objAppointmentItem As Object
Dim datStart As Date
Dim strSubject As String
Dim lngZeile As Long
'Hier beginnen die Termine
Range("B2").Select
lngZeile = 2
Do Until Cells(lngZeile, 1).Value = ""
datStart = Cells(lngZeile, 2).Value & " 08:00:00"
strSubject = "Geburtstag von: " & Cells(lngZeile, 1).Value

Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
If Not AppointmentExists(OutApp, datStart, strSubject) Then
With apptOutApp
'Datum und Uhrzeit
.Start = datStart
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
'Termininfo
.Subject = strSubject
'oder der Betreff steht in der Spalte rechts von den Terminen
'Zusätzlicher Text
.Body = ""
'ort
'######################## eingefügt ###########################
Set OutPattern = apptOutApp.GetRecurrencePattern
OutPattern.RecurrenceType = olRecursYearly
'##############################################################
.Location = "geboren am:" & " " & datStart
.Duration = "5"
'Erinnerung
.ReminderMinutesBeforeStart = 10
'mit Sound
.ReminderPlaySound = True
'Erinnerung wiederholen
.ReminderSet = True
.Categories = "Geburtstage"
'Termin speichern
.Save
End With
End If
'Nächste Zelle auswählen
'ActiveCell.Offset(1, 0).Select
lngZeile = lngZeile + 1
'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal
Set apptOutApp = Nothing
Set OutApp = Nothing
Set objOutlook = Nothing
Loop
'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal
MsgBox "Termine übertragen"
End Sub



Vielen Dank schon einmal

Gruß

Tom