Code Umstellung (Termine Excel in Outlook)
21.01.2019 10:52:31
Bibi
ich bin neu hier und bräuchte eure Hilfe um einen Code umzustellen. Ich bin durch Google auf folgenden Code gestoßen aber bin leider ziemlicher Neuling in VBA ich Bitte um euer Verständnis :-).
Der Code ist super und Funktioniert auch super nur kriege ich Ihn leider nicht vollständig auf meine Bedürfnisse umgestellt.
Um diesen Code geht es
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, boolAllDay As Variant, strCategory As String, strComment As _
String, rngEntryID As Range
' Outlook Objekt erstellen
Set objOL = CreateObject("Outlook.Application")
' check ob Kalender definiert wurde
While Range("calendarID").Value = "" And 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)
' Anfangszelle
Set rngStart = sheet.Range("A5")
' Endzelle ermitteln
Set rngEnd = sheet.Cells(Rows.Count, rngStart.Column).End(xlUp)
' Alle sichtbaren Zeilen verarbeiten
For Each cell In sheet.Range(rngStart, rngEnd).SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Verarbeite Termin in Zeile " & cell.Row & " ..."
' Werte der Spalten Variablen zuweisen
strSubject = cell.Text
strStartDate = cell.Offset(0, 1).Text
strEndDate = cell.Offset(0, 1).Text
boolAllDay = True
strCategory = "QS-KF"
strComment = "Deine Schulung" & " " & "läuft am" & " " & "ab."
' In dieser Spalte wird die Outlook-EntryID des Termins für eine spätere exakte _
Ermittlung eines bestehenden Termins gespeichert
Set rngEntryID = cell.Offset(0, 9)
' 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)
On Error GoTo 0
End If
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 boolAllDay = True 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
Next
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.", vbInformation
If cntFailed > 0 Then
MsgBox "Bei folgenden " & cntFailed & " Terminen sind Fehler aufgetreten:" & vbNewLine & _
_
_
vbNewLine & strFailed, vbExclamation
End If
End Sub
Jetzt hätte ich gerne noch folgende Punkte umgestellt.
1.) Holt er ja die Termine aus Spalte B hätte es aber gerne, wenn er die Termine aus den _
Spalten B bis H holt (alles verschiede Termine) das wäre ja der Code abschnitt:
strStartDate = cell.Offset(0, 1).Text
strEndDate = cell.Offset(0, 1).Text
2.) Wäre eine Erinnerung für die Termine aus den Spalten B,C+H 2 Wochen vorher und in den _
Spalten D bis G 6 Monate vorher, super wenn man das hinzufügen könnte.
' Erinnerung
.ReminderSet = False
3.) Wird der betreff immer aus der Spalte A geholt, diesen hätte ich gerne immer aus der _
Spaltenüberschrift des jeweiligen Termins (Zeile 4) z.B. Termin aus Spalte A 5 betreff = A4 usw. _
strComment = cell.Offset(0, 1).Text
4.) An dieser Stelle hätte ich gerne:
strComment = "Deine Schulung" & " " & "läuft am" & " " & "ab."
5.) Wäre es super das wenn man die Termine übertragen hat in der Spalte I ein grüner hacken ist und wenn man den Termin verändert hat ein Rotes X. Das man so eine bessere Übersicht hat.
6.) wenn man die Termine übertragen hat und in Spalte J die ID drin ist aber jemand den Termin in Outlook gelöscht hat kommt immer "Systemfehler &H8004010F (-2147221233)" und man kann die Termine nicht mehr hinzufügen kann man das ändern? Dass er die Termine einfach neu erstellt?
Hier auch mal die Datei zu den Problemen
https://www.herber.de/bbs/user/126963.xlsm
Ich hoffe das ich jetzt nicht zu unverschämt bin und nicht zu viele Punkte habe.
Ich bin froh für jede Hilfe und sage jetzt schon mal Danke für jede Hilfe und auch jede Mühe.
Gruß
Bibi