AW: Termine über Outlook aus Excel
12.11.2013 15:59:51
Tino
Hallo,
habe dir hier mal was zusammengebaut. (bitte erst testen, nicht ausgiebig getestet)
Ich würde mir in der Liste einen Vermerk erstellen
das heute an die Person aus Spalte A schon der Termin gesendet wurde,
sonst wird da schnell eine Mailbombe daraus.
Die Tabelle wo die Daten stehen müsstest Du noch anpassen.
Sub Start_Terminvergabe()
Dim ArrData(), ArBereiche()
Dim n&, nn&, nCount&
Dim SuchDate As Date, ValueDate As Date
Dim intJahr%, intMonat%, AnzahlTermine%
Dim strAufzahlungszeichen$
strAufzahlungszeichen = Chr(183)
With Tabelle1 'Tabelle anpassen
ArrData = .Range("A2:AV31").Value
SuchDate = CDate(Day(Date) & "." & .Range("A1") & "." & Year(Date)) + 1
If Month(SuchDate) <> Month(Date) Then
If DateDiff("m", Date, SuchDate) > 1 Then
MsgBox Format(SuchDate, "'mmmm.yyyy'") & " liegt zu weit in der Zukunft!"
Exit Sub
End If
If MsgBox("Sollen die Termine für den Monat " & Format(SuchDate, "'mmmm'") & _
" gesendet werden werden?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
End If
intJahr = Year(SuchDate)
intMonat = Month(SuchDate)
End With
For n = 3 To Ubound(ArrData)
Redim Preserve ArBereiche(Ubound(ArrData, 2))
If ArrData(n, 1) <> "" Then
For nn = 6 To Ubound(ArrData, 2)
If ArrData(n, nn) <> "" Then
If IsNumeric(ArrData(n, nn)) Then
ValueDate = DateSerial(intJahr, intMonat, ArrData(n, nn))
If ValueDate = SuchDate Then
ArBereiche(nCount) = vbTab & strAufzahlungszeichen & ArrData(1, nn)
nCount = nCount + 1
End If
End If
End If
Next nn
End If
If nCount > 0 Then
Redim Preserve ArBereiche(nCount - 1)
SendTermin ArrData(n, 1), SuchDate, ArBereiche
AnzahlTermine = AnzahlTermine + 1
End If
Erase ArBereiche: nCount = 0
Next n
MsgBox "Es wurden " & AnzahlTermine & " versendet"
End Sub
Sub SendTermin(ByVal strName$, ByVal TermDatum As Date, ArBereiche())
Dim strBody$
Dim outApp As Outlook.Application
Dim outTermin As AppointmentItem
'Prüfen ob Outlook gestartet ist
Call Open_Outlook
strBody = Join(ArBereiche, vbCr)
strBody = "Hallo," & vbCr & "in folgenden Bereich(en) steht für morgen den " & _
Format(TermDatum, "dd.mm.yyyy") & _
" ein Rundgang an!" & String(3, vbCr) & strBody
Set outApp = New Outlook.Application
Set outTermin = outApp.CreateItem(olAppointmentItem)
With outTermin
' .Display
.Importance = olImportanceHigh
.MeetingStatus = olMeeting
.Location = "Rundgang im Bereich" 'Ort
.Recipients.Add strName 'an
.AllDayEvent = True
.Start = Format(TermDatum, "dd.mm.yyyy")
.Subject = "Rundgang"
.Body = strBody
' .Duration = "0" '***dauer in Minuten ***
.ReminderMinutesBeforeStart = 0 '***Erinnerung vor Start in Minuten ***
.Send 'senden
'Sendkeys "%S" '*** automatisch ohne überprüfung senden !!!nur wenn sichtbar!!!***
.Close False 'schließen ohne speichern, sonst True
End With
Set outTermin = Nothing
Set outApp = Nothing
End Sub
'Prüfen ob Outlook offen, sonst starten
Sub Open_Outlook()
Dim objOut As Object
Dim strPath$
On Error Resume Next
Set objOut = GetObject(, "Outlook.Application")
On Error GoTo 0
If objOut Is Nothing Then
strPath = Application.Parent.Path
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
Shell strPath & "OUTLOOK.EXE", vbMinimizedFocus
End If
End Sub
Gruß Tino