Dim ol
Dim olns
Dim cal
Dim db
Dim rs
Dim dbe, myCalendar, myItem, dummy
Dim Query

on error resume next
Set dbe = CreateObject("DAO.DBEngine.35")

if not isobject(dbe) then Set dbe = CreateObject("DAO.DBEngine.36")
on error goto 0

  
' Tabelle Ferienliste öffnen
Set db = dbe.Workspaces(0).OpenDatabase("irgendwas.db", 1, True)
Set rs = db.OpenRecordset("Ferien")

set ol = WScript.CreateObject("Outlook.Application")
Set olns = ol.GetNamespace("MAPI")

Set myCalendar = olns.GetDefaultFolder(9)      ' opens calendarfolder

rs.MoveFirst
Do While (rs.EOF <> True)
  
   Query = "[Subject] = """ & rs.Fields("WarumFrei") & " (HEG)" & """ and " & _
           "[Start] = """ & CDate(rs.Fields("Datum")) & " 00:00"""
   
   Set myItem = myCalendar.Items.Find(Query)
   On Error Resume Next
   dummy = myItem
   If Err.Number = 91 Then		      ' if appointment doesn't exist, create a new one
        Err.Clear
        Set cal = ol.CreateItem(1)            ' create appointment
        cal.Subject = rs.Fields("WarumFrei") & " (HEG)"
        cal.Start = CDate(rs.Fields("Datum"))
        cal.AllDayEvent = True
        cal.BusyStatus = 2           ' abwesend
        cal.ReminderSet = False
        cal.Save
    End If
    rs.MoveNext
    Loop

Set olns = Nothing                  ' namespace aus dem Speicher löschen
Set ol = Nothing                    ' Outlook schliessen

MsgBox "Erfolg."