ich möchte aus meiner do do Liste wenn ich die Zelle M1:M100 anklicke das zum einem eine email versendet und zum anderen ein Termin angelegt wird.
Beides Funktioniert. Nun möchte ich aber auch das die beteiligeten Kollegen auch einen Termin bekommen bzw mit eingeladen werden.
'Öffnet mit Linksklick auf Zellen der Spalten H,I,J einen Kalender.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("H4:H100")) Is Nothing Then Call OpenCalender
If Not Intersect(Target, Range("I4:I100")) Is Nothing Then Call OpenCalender
If Not Intersect(Target, Range("J4:J100")) Is Nothing Then Call OpenCalender
'Öffnet mit Linksklick auf Zellen der Spalten M Outlook.
If Not Intersect(Target, Tabelle2.Range("M4:M100")) Is Nothing Then
Call sendEmail(zeile:=Target.Row)
End If
'Eintrag Termin in Outlook, sowie der mitwirkenden Mitarbeiter
If Not Intersect(Target, Tabelle2.Range("M4:M100")) Is Nothing Then
Call Outlook
End If
End Sub
Sub Outlook()
Dim OutApp
Dim apptOutApp
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1)
With apptOutApp
.Start = "28.08.2014" & " 18:00"
.Subject = "Test"
.Body = "Text"
.Location = "Testort"
.Duration = "19"
.Recipients.Add Tabelle2.Range("N" & zeile)
.ReminderMinutesBeforeStart = 10
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
Set apptOutApp = Nothing
Set OutApp = Nothing
MsgBox "E-Mail wurde verschickt und Termin angelegt"
End Sub Ich dachte ich könnte die Range, für die Adressen genau so anwenden wie bei deim
versenden der E-Mail. sendto = Tabelle2.Range("N" & zeile) aber das funktioniert nicht.
Noch mal kurz: Der befehl .Recipients.Add Tabelle2.Range("N" & zeile) funktioniert bei mir nicht. Was kann ich tun?
Gruß
Mulsch0r
Hier nochmal der gesamte Code falls es sonst zu Missverständissen kommt.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TRow As Integer
TRow = Target.Row
If Target.Column = 12 Then
If Target = "Erledigt" Then
Sheets("Aufgaben").Rows(TRow).Copy
Sheets("Erledigt").Cells(Sheets("Erledigt").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0). _
Row, 1).PasteSpecial
Sheets("Aufgaben").Rows(TRow).Delete Shift:=xlUp
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("H4:H100")) Is Nothing Then Call OpenCalender
If Not Intersect(Target, Range("I4:I100")) Is Nothing Then Call OpenCalender
If Not Intersect(Target, Range("J4:J100")) Is Nothing Then Call OpenCalender
If Not Intersect(Target, Tabelle2.Range("M4:M100")) Is Nothing Then
Call sendEmail(zeile:=Target.Row)
End If
If Not Intersect(Target, Tabelle2.Range("M4:M100")) Is Nothing Then
Call Outlook
End If
End Sub
Public Function sendEmail(zeile As Long)
On Error GoTo ende
esubject = "Bitte folgende Aufgabe(n) erledigen"
sendto = Tabelle2.Range("N" & zeile)
ebody = "Hallo," & vbCrLf & vbCrLf & _
"Projekt: " & Tabelle2.Range("C" & zeile) & vbCrLf & _
"Auftrag: " & Tabelle2.Range("D" & zeile) & vbCrLf & _
"Verantwortlicher: " & Tabelle2.Range("E" & zeile) & vbCrLf & _
"Mitarbeiter: " & Tabelle2.Range("F" & zeile) & vbCrLf & vbCrLf & _
"Aufgabe: " & Tabelle2.Range("G" & zeile) & vbCrLf & _
"Start Aufgabe: " & Tabelle2.Range("H" & zeile) & vbCrLf & _
"Kontrolltermin: " & Tabelle2.Range("I" & zeile) & vbCrLf & _
"Abgabetermin: " & Tabelle2.Range("J" & zeile) & vbCrLf & _
"Bemerkung: " & Tabelle2.Range("K" & zeile) & vbCrLf & _
"Projetpfad: " & Tabelle2.Range("O" & zeile) & vbCrLf
newfilename = "U:\Test.pdf"
Set app = CreateObject("outlook.Application")
Set itm = app.CreateItem(0)
With itm
.Subject = esubject
.to = sendto
.cc = ccto
.Body = ebody
.attachments.Add (newfilename)
.display
.send
End With
Set app = Nothing
Set itm = Nothing
ende:
End Function
Sub Outlook()
Dim OutApp
Dim apptOutApp
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1)
With apptOutApp
.Start = "28.08.2014" & " 18:00"
.Subject = "Test"
.Body = "Text"
.Location = "Testort"
.Duration = "19"
'.Recipients.Add Tabelle2.Range("N" & zeile)
.ReminderMinutesBeforeStart = 10
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
Set apptOutApp = Nothing
Set OutApp = Nothing
MsgBox "E-Mail wurde verschickt und Termin angelegt"
End Sub