AW: Excel-Daten in Outlook Kalender übermitteln
14.07.2008 11:41:30
Ramses
Hallo
Den Bereich wo die Daten herkommen musst du halt anpassen
'************************************
'Start Codesequenz
Sub Excel_Control_Termin_nach_Outlook()
'(C) Ramses
'E 2000
'Dim OutApp As Outlook.Application
Dim OutApp As Object, apptOutApp As Object
Dim apptFolder As Object
Dim myC As Range, schedRange As Range
'Hier beginnen die Termine
Set schedRange = Range("A5:A100")
'Outlook initialiseren
Set OutApp = CreateObject("Outlook.Application")
'Default Kalender
Set apptFolder = myOLApp.GetNamespace("MAPI").GetDefaultFolder(9)
For Each myC In schedRange
'Wenn in der Zelle was drin steht
If myC <> "" Then
'beim ersten Aufruf muss ja noch kein
'Termin geprüft werden
If myC.Row > schedRange.Cells(1, 1).Row Then
'Doppeltermin im Bereich prüfen
'Kann notfalls entfernt werden
If checkSchedDate(Range("" & schedRange.Cells(1, 1).Address & ":" & myC.Offset(-1, 0).Address & ""), myC.Value) = True Then
'Es hat an diesem Tag schon einen Termin gegeben
GoTo nextsched
End If
'Prüfen ob der Termin in Outlook schon existiert
If checkAppt(apptFolder, myC) = True Then
Qe = MsgBox("Zu diese Zeitpunkt: """ & myC & """ existiert bereits ein Termin." & vbCrLf & "Termin trotzdem erstellen ?" & _
vbCrLf, vbYesNo + vbDefaultButton2, "Doppelter Termin")
If Qe = vbYes Then
With apptOutApp
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
'Datum und Uhrzeit
'Hier werden zum aktuellen Tag 7 Tage addiert
'Start = Format(Now() + 7, "dd.mm.yyyy") & " 08:00"
'Alternativ werden die Termine aus der Zelle genommen
.start = Format(myC.Value, "dd.mm.yyyy") & " 08:00"
'Termininfo
'Subject = "Rechnung: " & ActiveWorkbook.Name & " kontrollieren"
'oder der Betreff steht in der Spalte rechts von den Terminen
.Subject = ActiveCell.Offset(0, 1)
'Zusätzlicher Text
'2 Spalten nach rechts
.Body = ActiveCell.Offset(0, 2)
'ort =
'3 Spalten rechts
.Location = ActiveCell.Offset(0, 3)
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
.Duration = "5"
'Erinnerung
.ReminderMinutesBeforeStart = 10
'mit Sound :-)
.ReminderPlaySound = True
'Erinnerung wiederholen
.ReminderSet = True
'Termin speichern
.Save
End With
End If
End If
End If
End If
nextsched:
Next
'Nächste Zelle auswählen
'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal
Set apptOutApp = Nothing
Set OutApp = Nothing
MsgBox "Termine an Outlook übertragen!"
End Sub
Function checkSchedDate(chkRange As Range, chkDate As Date) As Boolean
'(C) Ramses
'Es wird geprüft ob in dem bisher abgearbeiteten
'Bereich bereits das gleiche Datum vorhanden ist
'Wenn ja, dann wird der übergebene Termin verworfen
'und nicht nach Outlook übertragen
Dim chkC As Range
For Each chkC In chkRange
If chkC = chkDate Then
checkSchedDate = True
Exit Function
End If
Next
checkSchedDate = False
End Function
Function chkAppt(chkFolder As Object, newAppt As String) As Boolean
'(C) Ramses
'Es wird geprüft, ob der Termin im Kalender bereits existiert
Dim appItem As Object
chkAppt = True
For Each appItem In chkFolder.Items
If appItem.Subject = newAppt Then Exit Function
Next
chkAppt = False
End Function
'Ende Codesequenz
'********************************************
Existierende Termine werden grundsätzlich nicht überschrieben, sondern allenfalls doppelt angelegt.
Gruss Rainer