Gruppe
Funktion
Problem
Werte sollen in einem zweiten Blatt transponiert dargestellt werden.
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