Hallo zusammen,
ich bin ein absoluter VBA Noob und habe diesen Code im Internet gefunden:
Sub chooseOutlookCalendar()
Set objOL = CreateObject("Outlook.Application")
MsgBox "Bitte markieren sie im nächsten Dialog den Kalender den sie verwenden möchten.", vbInformation
Set objCal = objOL.Session.Pickfolder
If Not objCal Is Nothing And objCal.DefaultItemType = 1 Then
Range("calendarID").Value = objCal.EntryID
Range("storeID").Value = objCal.StoreID
Else
MsgBox "Sie müssen einen ""Kalender""-Ordner wählen. Bitte wiederholen sie die Eingabe.", vbExclamation
End If
End Sub
Sub createAppointments()
Dim sheet As Worksheet, rngStart As Range, rngEnd As Range, cell As Range, cntUpdate As Long, cntNew As Long, cntFailed As Long, strFailed As String, olApp As Object, isUpdate As Boolean, isFail As Boolean
Dim strSubject As String, strStartDate As String, strStartTime As String, strEndDate As String, strEndTime As String, strAllDay As String, strCategory As String, strComment As String, rngEntryID As Range
Dim rngDelete As Range, cntDelete As Long
' Outlook Objekt erstellen
Set objOL = CreateObject("Outlook.Application")
' check ob Kalender definiert wurde
While Range("storeID").Value = "" Or Range("calendarID").Value = ""
MsgBox "Bitte wählen sie zuerst einen Kalender aus.", vbExclamation
chooseOutlookCalendar
Wend
' Kalender-Ordner aus ID ermitteln
Set objCal = objOL.Session.GetFolderFromID(Range("calendarID").Value, Range("storeID").Value)
'Sheet 1
Set sheet = Worksheets(1)
With sheet
' Anfangszelle
Set rngStart = .Range("A5")
' Endzelle ermitteln
Set rngEnd = .Cells(Rows.Count, rngStart.Column).End(xlUp)
' Alle sichtbaren Zeilen verarbeiten
For Each cell In .Range(rngStart, rngEnd).SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Verarbeite Termin in Zeile " & cell.Row & " ..."
' Werte der Spalten Variablen zuweisen
strSubject = cell.Text
strStartDate = .Cells(cell.Row, "B").Text
strStartTime = .Cells(cell.Row, "C").Text
strEndDate = .Cells(cell.Row, "D").Text
strEndTime = .Cells(cell.Row, "E").Text
strAllDay = .Cells(cell.Row, "F").Text
strCategory = .Cells(cell.Row, "G").Text
strComment = .Cells(cell.Row, "H").Text
deleteEntry = .Cells(cell.Row, "I").Text
' In dieser Spalte wird die Outlook-EntryID des Termins für eine spätere exakte Ermittlung eines bestehenden Termins gespeichert
Set rngEntryID = .Cells(cell.Row, "J")
' Gibt es bereits eine EntryID für den Termin, dann hole den Termin direkt?
If rngEntryID.Value > "" Then
On Error Resume Next
Set olApp = objOL.Session.GetItemFromID(rngEntryID.Value, objCal.StoreID)
If Err.Number > 0 Then Set olApp = Nothing
On Error GoTo 0
End If
' entscheiden ob Termin gelöscht werden soll
If deleteEntry = "Ja" And Not olApp Is Nothing Then
olApp.Delete
cntDelete = cntDelete + 1
' Zeile in Range speichern um am Schluss die zu löschenden Termine aus der Tabelle zu entfernen
If rngDelete Is Nothing Then
Set rngDelete = cell.EntireRow
Else
Set rngDelete = Union(rngDelete, cell.EntireRow)
End If
Else
If olApp Is Nothing Then
' wurde der Termin nicht gefunden oder es existiert noch keine EntryID erstelle einen neuen Termin
Set olApp = objCal.items.Add(1)
isUpdate = False
Else
' es ist ein Update
isUpdate = True
End If
'Termin anpassen
With olApp
' Betreff zuweisen
.Subject = strSubject
' Erinnerung
.ReminderSet = False
' Kategorie zuweisen
If strCategory > "" Then
.Categories = strCategory
End If
' Kommentar hinzufügen
.Body = strComment
If strAllDay = "Ja" Then
' Ist Ganztagesevent
.AllDayEvent = True
' Wenn Datumswerte korrekt sind
If IsDate(strStartDate) Then
' Startdatum setzen
.Start = DateValue(strStartDate)
' Wenn Enddatum nicht angegeben wurde nehme an das der Termin 1 Tag dauert
strEndDate = IIf(strEndDate > "", strEndDate, strStartDate)
' Enddatum muss für Ganztagesevents immer einen Tag größer sein
.End = DateAdd("d", 1, DateValue(strEndDate))
' Speichern
.Save
isFail = False
Else
isFail = True
End If
Else
' Ist kein Ganztagesevent
.AllDayEvent = False
' Wenn Datumswerte korrekt sind
If IsDate(strStartDate) And IsDate(strEndDate) And IsDate(strStartTime) And IsDate(strEndTime) Then
' Setze Start und Endzeit und speichere
.Start = CDate(strStartDate & " " & strStartTime)
.End = CDate(strEndDate & " " & strEndTime)
.Save
isFail = False
Else
isFail = True
End If
End If
If isFail Then
' Datumsformat nicht korrekt
strFailed = strFailed & "- Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & " hat ungültige oder fehlende Zeitangaben" & vbNewLine
cntFailed = cntFailed + 1
Else
If isUpdate Then
cntUpdate = cntUpdate + 1
Else
cntNew = cntNew + 1
End If
End If
' EntryID zum Termin speichern
rngEntryID.Value = .EntryID
End With
Set olApp = Nothing
End If
Next
If Not rngDelete Is Nothing Then rngDelete.Delete
Set objOL = Nothing
Set objCal = Nothing
Application.StatusBar = ""
' Ergebnisse ausgeben
MsgBox "Ergebnis: " & vbNewLine & vbNewLine & cntNew & " Termin(e) wurden hinzugefügt." & vbNewLine & cntUpdate & " Termin(e) wurden aktualisiert." & vbNewLine & cntDelete & " Termin(e) wurden gelöscht.", vbInformation
If cntFailed > 0 Then
MsgBox "Bei folgenden " & cntFailed & " Terminen sind Fehler aufgetreten:" & vbNewLine & vbNewLine & strFailed, vbExclamation
End If
End With
End Sub
Dieser Code erstellt Termine aus Excel nach Outlook. Soweit so gut. Ich möchte diese Version allerdings erheblich abspecken. Heißt: Uhrzeit soll raus, Kategorie soll raus, Funktion einen Termin löschen zu können soll raus, Entry ID soll raus und es soll automatisch immer der eigene Outlook Ordner ausgewählt werden, ohne dass man etwas manuell auswählen muss. Könnt ihr mit weiterhelfen? Danke!