AW: Leider schaffe ich es nicht das Marko anpassen
10.09.2010 12:00:32
EvilRik
Hallo Lemmi;
in Klasse: Worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range, rngTmp As Range
Set rngBereich = Range("D6", Cells(Rows.Count, 4).End(xlUp)).Resize(, 13) '!!!
If Not Intersect(rngBereich, Rows("1:5")) Is Nothing Then Exit Sub
Set rngBereich = Intersect(rngBereich, Target)
If rngBereich Is Nothing Then Exit Sub
Set rngBereich = rngBereich.Columns(1).Cells
Debug.Print rngBereich.Address
Call Schreibe_In_Outlook(rngBereich)
End Sub
im Modul1:
Option Explicit
Sub Schreibe_In_Outlook(ByVal rngBereich As Range)
Dim objOutlook As Object, objNameSpace As Object
Dim objMapiFolder As Object, objItems As Object
Dim vonDatum As Date, bisDatum As Date, LMinuten As Long
Dim strBetreff As String, strBody As String
Dim meAr, booFind As Boolean
For Each rngBereich In rngBereich
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objMapiFolder = objNameSpace.GetDefaultFolder(9)
With Sheets(rngBereich.Parent.Name)
meAr = .Cells(rngBereich.Row, 4).Resize(, 13) '!!!
End With
If meAr(1, 1) "" And IsDate(meAr(1, 5)) And meAr(1, 13) >= 0 Then '!!!
strBetreff = "Kündigungsfrist:" & meAr(1, 1) 'Betreffzeile
vonDatum = (meAr(1, 5) + TimeSerial(8, 0, 0)) - 7 * meAr(1, 12) 'von '!!!
bisDatum = (meAr(1, 9) + TimeSerial(8, 30, 0)) - 7 * meAr(1, 12) 'bis '!!!
strBody = "Termineintrag: Hallo Lemmi," & Chr(10) & _
"der " & meAr(1, 1) & " läuft in " & meAr(1, 13) & " Wochen aus !" 'Body '!!!
'dauer in Minuten berechnen
LMinuten = Application.WorksheetFunction.Round((bisDatum - vonDatum) * 1440, 0)
Set objItems = objMapiFolder.Items
objItems.Sort "[Start]"
objItems.IncludeRecurrences = True
Set objItems = objItems.Restrict("[Subject] = '" & strBetreff & "'")
For Each objItems In objItems
If objItems.Subject = strBetreff Then: booFind = True: Exit For
Next objItems
If Not booFind Then
Set objItems = Nothing
End If
booFind = False
If Not objItems Is Nothing Then
With objItems
If objItems.Subject = strBetreff And (meAr(1, 11) = "nein" Or meAr(1, 11) = _
"") Then '!!!
'hier löschen
.Delete
Else
'hier berabeiten *************************
.body = strBody
.Start = Format(vonDatum, "dd.mm.yyyy hh:mm")
.Duration = LMinuten 'dauer in Minuten
.Save
End If
End With
ElseIf meAr(1, 11) = "ja" Then '!!!
'hier anlegen *************************
Set objItems = objMapiFolder.Items.Add
With objItems
.Subject = strBetreff
.body = strBody
.Start = Format(vonDatum, "dd.mm.yyyy hh:mm")
.Duration = LMinuten 'dauer in Minuten
.Save
End With
End If
End If
Next rngBereich
Set objNameSpace = Nothing
Set objNameSpace = Nothing
Set objMapiFolder = Nothing
Set objItems = Nothing
End Sub
Gruß Henrik