Thema: Trainingsplan in einen Outlook-Kalender einlesen

StandardModule: Modul1

Sub WriteCalendar()
   Dim olApp As Outlook.Application
   Dim olNS As Outlook.NameSpace
   Dim olCal As Outlook.MAPIFolder
   Dim olApt As AppointmentItem
   Dim iRow As Integer
   Set olApp = CreateObject("Outlook.Application")
   Set olNS = olApp.GetNamespace("MAPI")
   On Error Resume Next
   Set olCal = olNS.GetDefaultFolder(olFolderCalendar).Folders("Training")
   If Err Then
      Set olCal = olNS.GetDefaultFolder(olFolderCalendar).Folders.Add("Training")
      Err.Clear
   End If
   iRow = 4
   Do Until IsEmpty(Cells(iRow, 1))
      Set olApt = olApp.CreateItem(olAppointmentItem)
      With olApt
         .Start = Cells(iRow, 1).Value + Cells(iRow, 3).Value
         .End = Cells(iRow, 1).Value + Cells(iRow, 4).Value
         .Subject = "Trainingstag"
         .Location = Cells(iRow, 5).Value
         .Body = Cells(iRow, 6).Value & " mitbringen"
         .BusyStatus = olBusy
         .ReminderMinutesBeforeStart = 120
         .ReminderSet = True
         .Save
         .Move olCal
      End With
      iRow = iRow + 1
   Loop
ERRORHANDLER:
   Set olApt = Nothing
   Set olCal = Nothing
   Set olNS = Nothing
   Set olApp = Nothing
End Sub

Sub ReadCalendar()
   Dim olApp As Outlook.Application
   Dim olNS As Outlook.NameSpace
   Dim olCal As Outlook.MAPIFolder
   Dim olApt As AppointmentItem
   Dim dat As Date
   Dim iRow As Integer
   Dim sTxt As String
   Application.ScreenUpdating = False
   On Error GoTo ERRORHANDLER
   Workbooks.Add 1
   Set olApp = CreateObject("Outlook.Application")
   Set olNS = olApp.GetNamespace("MAPI")
   Set olCal = olNS.GetDefaultFolder(olFolderCalendar).Folders("Training")
   ThisWorkbook.Worksheets(1).Range("A1:F3").Copy Range("A1")
   iRow = 4
   For Each olApt In olCal.Items
      dat = olApt.Start
      Cells(iRow, 1).Value = Fix(dat)
      Cells(iRow, 2).Value = Format(Fix(dat), "ddd")
      Cells(iRow, 3).Value = CDbl(dat) - Fix(dat)
      dat = olApt.End
      Cells(iRow, 4).Value = CDbl(dat) - Fix(dat)
      Cells(iRow, 5).Value = olApt.Location
      sTxt = olApt.Body
      Cells(iRow, 6).Value = Left(sTxt, InStr(sTxt, " ") - 1)
      iRow = iRow + 1
   Next olApt
   Columns("A").NumberFormat = "dd.mm.yy"
   Columns("C:D").NumberFormat = "hh:mm"
   Columns.AutoFit
ERRORHANDLER:
   Application.ScreenUpdating = True
   Set olApt = Nothing
   Set olCal = Nothing
   Set olNS = Nothing
   Set olApp = Nothing
End Sub

Beiträge aus dem Excel-Forum zu den Themen Extern und Outlook