AW: VBA import in Outlook
29.09.2016 09:45:15
Scheidegger
Hallo
Ich noch einmal. Habe wie schon vorher beschrieben ein anderes Makro im Internet gefunden und leicht angepasst. Alles würde funktionieren, ausser dass es mir bei Erinnerung nichts mitgibt. Habe dazu den folgenden Code:
Sub createAppointments()
On Error Resume Next
Dim sheet As Worksheet, rngStart As Range, rngEnd As Range, cell As Range, _
colRem As Range, remindd As Range, objRem As Range
Set objOL = CreateObject("Outlook.Application")
Set objCal = objOL.Session.GetDefaultFolder(9)
Set sheet = Worksheets(1)
Set rngStart = sheet.Range("A2")
Set rngEnd = rngStart.End(xlDown)
Set remindd = Outlook.Reminders
Set objRem = colReminders.Item(1)
counter = 0
For Each cell In sheet.Range(rngStart, rngEnd)
strSubject = cell.Text
strStartDate = cell.Offset(0, 1).Text 'B= Beginntam
strStartTime = cell.Offset(0, 2).Text 'C= Beginntum
strEndDate = cell.Offset(0, 3).Text 'D= Beginntam
strEndTime = cell.Offset(0, 4).Text 'E= Enddatum
boolAllDay = cell.Offset(0, 5).Value 'F= Ganztägig
objRem = cell.Offset(0, 6).Value 'G= ErinnerungEinAus
remindd = cell.Offset(0, 7).Text 'H= Erinnerungam
strCategory = cell.Offset(0, 11).Text 'L= Kategorie
strComment = cell.Offset(0, 9).Text 'J= Beschreibung
'####################################################################################### _
' Spalten
' Betreff(A), Beginntam(B), Beginntum(C), Beginntam(D), Endetum(E), Ganztägig(F),
' ErinnerungEinAus(G), Erinnerungam(H), Erinnerungum(I), Beschreibung(J), Ort _
Kategorien(K)
'####################################################################################### _
'Eventuelles Duplikat des Termins finden ---------
Dim dupe_item As Object, itm As Object
If boolAllDay Then
Set dupe_item = objCal.items.Restrict("[Start] = """ & Format(strStartDate, "ddddd") _
& _
" 12:00 AM"" AND [END] = """ & Format(DateAdd("d", 1, DateValue(strEndDate)), " _
ddddd") & _
" 12:00 AM"" AND [Subject] = '" & strSubject & "'")
Else
Set dupe_item = objCal.items.Restrict("[Start] = """ & Format(strStartDate & " " & _
_
strStartTime, "ddddd h:nn AMPM") & """ AND [END] = """ & Format(strEndDate & " " & _
_
strEndTime, "ddddd h:nn AMPM") & """ AND [Subject] = '" & strSubject & "'")
End If
Set itm = dupe_item.GetFirst
Set olApp = IIf(itm Is Nothing, objCal.items.Add(1), itm)
With olApp
.Subject = strSubject
.ReminderSet = False
If strCategory "" Then
.Categories = strCategory
End If
.Body = strComment
If boolAllDay = True Then
.AllDayEvent = True
If IsDate(strStartDate) Then
.Start = DateValue(strStartDate)
.End = DateAdd("d", 1, DateValue(strStartDate))
.Save
counter = counter + 1
Else
MsgBox "Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & _
_
" hat ungültige oder fehlende Zeitangaben", vbExclamation
End If
Else
.AllDayEvent = False
If IsDate(strStartDate) And IsDate(strEndDate) And IsDate(strStartTime) And _
IsDate(strEndTime) Then
.Start = DateValue(strStartDate) & " " & TimeValue(strStartTime)
.End = DateValue(strEndDate) & " " & TimeValue(strEndTime)
.Save
counter = counter + 1
Else
MsgBox "Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & _
_
" hat ungültige oder fehlende Zeitangaben", vbExclamation
End If
End If
End With
Next
Set objOL = Nothing
MsgBox counter & " Termin(e) wurden erstellt!", vbInformation
End Sub