Excel Tabelle als Termine in Outlook
19.02.2008 09:25:00
Bolo
Ich hab da mal ne Frage, also ich habe hier eine Excel-Tabelle, in welcher, in der ersten Spalte, jeweils ein Datum, in der zweiten Spalte ein Name und in der dritten eine Uhrzeit. Es is sozusagen ne Geburtstagsliste. Funktioniert soweit auch ganz gut, aber Problem is das es anscheinend bei einem Kollegen nicht funzt, bei allen anderen ja. Nun die Frage, könntet ihr ma rübergucken ob euch noch was auffällt? Ich bin ratlos.... :(
Sub Bday()
Dim myOLApp As Object
Dim myItem As Object
Dim myFolder As Object
Dim i As Long
Dim strSubject As String
Dim dStart As Date
Set myOLApp = CreateObject("Outlook.Application")
Set myFolder = myOLApp.GetNameSpace("MAPI").GetDefaultFolder(9)
With Worksheets("Geburtstage")
i = 2
Do While .Cells(i, 1).Value ""
strSubject = .Cells(i, 3)
dStart = .Cells(i, 1).Value + .Cells(i, 2).Value
If Not AppointmentExists(myFolder, strSubject) Then
Set myItem = myOLApp.CreateItem(1)
With myItem
.Subject = strSubject
.Body = "Gratulieren nicht vergessen!"
.Location = "Storkower Straße 127 - 133"
.Start = dStart
.Duration = 10
.Alldayevent = True
If WorksheetFunction.Weekday(dStart, 2) = 1 Then
.ReminderMinutesBeforeStart = 4320
Else
.ReminderMinutesBeforeStart = 1440
End If
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
Else
Debug.Print strSubject & " existiert"
End If
i = i + 1
Loop
End With
MsgBox "Termine an Outlook übertragen!"
Set myFolder = Nothing
Set myOLApp = Nothing
End Sub
Private Function AppointmentExists(objFolder As Object, strSubject As String) As Boolean
Dim objItem As Object
AppointmentExists = True
For Each objItem In objFolder.Items
If objItem.Subject = strSubject Then Exit Function
Next
AppointmentExists = False
End Function