Excel vba Excel-Termin nach Outlook

[sharky51]

Hallo zusammen,

darf ich Euch wieder einmal um Eure Hilfe bitten?

Termine aus einer Exceltabelle schreibe ich per vba in meinen Qutlook-Kalender.
Funktioniert auch alles super bis auf die Möglichkeit Termine in 3-monatigem Abstand zu schreiben.

Vielleicht kann mir jemand auf die Sprünge helfen was bei dem Case is = "Quartal" nicht stimmt.
Hier wird der generierte Termin nicht im Abstand von 3 Monaten eingetragen, sondern in drei folgende Monate hintereinander.

Code:

'Serien-Termine eintragen
Sub Einfügen()
  'adds a list of appontments to the Calendar in Outlook
  Dim olApp As Outlook.Application
 
  Dim olAppItem As Outlook.AppointmentItem
  Dim OutApp As Object, apptOutApp As Object, oApp As Object, oAddr As Object, opattern As Object
  Dim OutPattern As RecurrencePattern
  Dim datStart As Date
 
  Dim endRow As Long
  Dim row As Long
  Dim Alter
  Dim Trepeat 'Wiederholungsschlüssel
  Dim Dauer
 
  Dim zeile As Long, Zeile1 As Long, Suchbegriff As Long
  zeile = Range("A65536").End(xlUp).row
 
  Set oApp = CreateObject("outlook.application")
  Set oAddr = oApp.CreateItem(olAppointmentItem)
 
  endRow = zeile
  On Error Resume Next
  Set olApp = GetObject("", "Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
      On Error Resume Next
      Set olApp = GetObject("Outlook.Application")
      On Error GoTo 0
      If olApp Is Nothing Then
        MsgBox "Outlook is not available!"
        Exit Sub
      End If
  End If
 
  For row = startRow To endRow
      Set OutApp = CreateObject("Outlook.Application")
      Set apptOutApp = OutApp.CreateItem(olAppointmentItem) 'olAppointmentItem)
     
      'Wenn Termin bereits existiert dann nichts ändern
      If (Cells(row, colDelRaster).Text = "x") Or (Cells(row, colDelRaster).Text = "X") Then GoTo Weiter
      With apptOutApp
        'set default appointment values
        .AllDayEvent = True                'Ganztägig Beginn Tag x 00:00 Uhr bis Tag x+1 00:00 Uhr
        .Subject = "No subject"
        .Location = "Hier"
        .Body = ""
        .ReminderSet = True
        'read appointment values from the worksheet
        On Error Resume Next
        .Subject = Cells(row, colSubject).Value

        'Ort
        .Location = Cells(row, colLocation).Value
        .Start = Cells(row, colDatStart).Value + Cells(row, colTimeBeg).Value
        .End = Cells(row, colDatEnd).Value + Cells(row, colTimeEnd).Value
       
        'Duration
        If (Cells(row, colTimeBeg).Value = 0) And (Cells(row, colTimeEnd).Value = 0) Then
            'ganztägier Event
            .AllDayEvent = True
        Else
            'Dauer in Minuten
            Dauer = Abs(DateDiff("n", Cells(row, colTimeEnd).Value, Cells(row, colTimeBeg).Value))
            .Duration = Dauer  'DateDiff("n", wksSheet.Cells(lngRow, 6).Value, wksSheet.Cells(lngRow, 5).Value)
        End If
       
        .ReminderMinutesBeforeStart = 720

        'mit Sound
        .ReminderPlaySound = True
       
        'Farbkennzeichnung des Termins
        .Categories = Cells(row, colColorKat).Value  'z.B. "Grüne Kategorie"
       
        'Raster für Wiederholungen
        Set OutPattern = apptOutApp.GetRecurrencePattern
       
        Trepeat = Cells(row, colTRaster).Value
        Select Case Trepeat
            Case Is = "Jahr"
              OutPattern.RecurrenceType = 5 'olRecursYearly        'wiederkehrender Termin
              .GetRecurrencePattern.NoEndDate = False
              OutPattern.Occurrences = Cells(row, colRepeat).Value 'x Wiederholungen
              .Subject = Cells(row, colSubject).Value & ": " & Cells(row, colObject).Value & " (Wird " & Cells(row, colAlter).Value & " Jahre alt.)"
              Cells(row, colTRaster - 1).Value = ""
              '.GetRecurrencePattern.PatternStartDate = .Start = Cells(row, 3).Value '"Hier das Startdatum angeben."
              '.GetRecurrencePattern.Interval = 1
              'OutPattern.Occurrences = 2                        'x Wiederholungen
              '.GetRecurrencePattern.NoEndDate = True
 
            ' **** Fehlerhafter Teil **** 
            Case Is = "Quartal"
              OutPattern.RecurrenceType = 3 'olRecursYearly        'Quartal - wiederkehrender Termin
              OutPattern.RecurrenceType = olRecursMonthNth          'wiederkehrender Termin
              OutPattern.Occurrences = Cells(row, colRepeat).Value  'x Wiederholungen
' **** Ende ****
             
            Case Is = "Monat"
              OutPattern.RecurrenceType = olRecursMonthly    'wiederkehrender Termin
             
            Case Is = "Woche" 'mit fest vorgegebenem Wochentag - hier Dienstag
              OutPattern.RecurrenceType = olRecursWeekly      'wiederkehrender Termin
              OutPattern.DayOfWeekMask = olTuesday            'Wochentag
              OutPattern.Occurrences = Cells(row, colRepeat).Value  '31 'x Wiederholungen
 
              'mit Sound
              .ReminderPlaySound = True
             
              'Farbkennzeichnung des Termins
              '.OlCategoryColor = 5 'olCategoryColorGreen
              .Categories = Cells(row, colColorKat).Value  'z.B. "Grüne Kategorie"
             
            Case Is = "Tag"
              OutPattern.RecurrenceType = olRecursDaily    'wiederkehrender Termin
              OutPattern.Occurrences = Cells(row, colRepeat).Value  '31 'x Wiederholungen
             
            Case Is = "Serien-Tage" 'mit vorgegebenem Wochentag - abhängig vom angegebenen Starttag
              OutPattern.RecurrenceType = olRecursWeekly    'wiederkehrender Termin
              OutPattern.Occurrences = Cells(row, colRepeat).Value  '31 'x Wiederholungen
             
            Case Else
              'MsgBox "Einige Termine wurden nicht angelegt!"
              GoTo Weiter
        End Select
       
        .Duration = "2"
        On Error GoTo 0
        '.Save
        .Save
       
        ActiveSheet.Cells(row, colDelRaster) = "x"
        ActiveSheet.Cells(row, colOLentryID) = .EntryID
        Trepeat = 0
      End With
Weiter:
  Next
 
  If Cells(row, colSubject).Value = "" Then Exit Sub
 
  Set olAppItem = Nothing
  Set olApp = Nothing
 
  MsgBox "Alle Einzel & Serien-Termine wurden generiert"
End Sub

[Lutz Fricke]

Hallo Erich,

ich kenne nicht die Lösung, aber ich sehe den Fehler...

In den Zeilen

Code:

              OutPattern.RecurrenceType = 3 'olRecursYearly        'Quartal - wiederkehrender Termin
              OutPattern.RecurrenceType = olRecursMonthNth          'wiederkehrender Termin

definierst Du zuerst, dass das Ereignis jährlich auftritt, in der zweiten Zeile definierst Du es dann als monatliches.

Die zweite Zuweisung muss die falsche Eigenschaft sein.
Ist ja auch im Outlook ein zweites Feld.

Gruß,
Lutz

[sharky51]

Hallo Lutz,

vielen Dank für den Hinweis.

Ich habe das Problem nun auf folgende Weise gelöst:

Code:

Case Is = "Quartal"
              OutPattern.RecurrenceType = olRecursMonthly              'wiederkehrender Termin
              OutPattern.PatternStartDate = Cells(row, colDatStart).Value
              OutPattern.Interval = 3
              OutPattern.PatternEndDate = Cells(row, colDatGeb).Value