Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Trainingsplan in einen Outlook-Kalender einlesen

Gruppe

Outlook

Problem

Der Trainingsplan wird in einen neu angelegten Ordner "Training" im Outlook-Kalender übertragen. In einer zweiten Prozedur wird der Kalender ausgelesen.

Lösung
Geben Sie den Code in ein Standardmodul ein und weisen Sie ihn zwei Schaltflächen zu.

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