Nachricht an Hajo
29.07.2007 18:35:47
Mat
nachdem der Beitrag verschwunden war, hab ich ihn nochmal ins Formum gestellt. Der Code funktioniert jetzt mit der Ausnahme, dass wenn das Enddatum über die Datumsgrenze hinaus geht die Dauer auf 30 min. begrenzt wird.
Läßt sich da was machen oder geht es grundsätzlich nicht wenn die Datumsgrenze überschritten wird?
Gruß Mat
Sub WriteCalendar() Dim SpalteStart, SpalteEnde, iRow 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) If IsEmpty(Cells(iRow, 9)) Then SpalteStart = 13 Else SpalteStart = 9 'Änderung der Stalte wenn _ I gleich leer If IsEmpty(Cells(iRow, 10)) Then SpalteEnde = 14 Else SpalteEnde = 10 'Änderung der Stalte wenn _ J gleich leer If IsEmpty(Cells(iRow, SpalteStart)) = False And IsEmpty(Cells(iRow, SpalteEnde)) = False Then ' _ Zulassung wenn Start und Ende enthalten sind With olApt .Start = Cells(iRow, 2).Value + Cells(iRow, SpalteStart).Value .End = Cells(iRow, 2).Value + Cells(iRow, SpalteEnde).Value .Subject = "Dienst" .Location = Cells(iRow, 7).Value .Body = Cells(iRow, 19).Value & " Streifenpartner" .BusyStatus = olBusy .ReminderMinutesBeforeStart = 120 .ReminderSet = True .Save .Move olCal End With End If iRow = iRow + 1 Loop ERRORHANDLER: Set olApt = Nothing Set olCal = Nothing Set olNS = Nothing Set olApp = Nothing End Sub