Option Explicit
Sub Dienstplan()
Dim Pfad As String, Datei As String, Ext As String
Dim Blatt As Worksheet, Rng As String, Empf As String
'Pfad für Temporäre Speicherung
Pfad = "E:\excel\temp\" 'mit \ am Ende
Ext = ".xlsx"
'Zelle für Empfänger
Rng = "A1"
For Each Blatt In ThisWorkbook.Sheets
Select Case Blatt.Name
Case "DiesesNicht", "DasauchNicht"
'mache nix
Case Else
'Empfänger aus Zelle
Empf = Blatt.Range(Rng)
If Empf = "" Then
MsgBox "Fehler! Empfänger in Blatt: " & Blatt.Name
Else
'in neues Blatt kopieren
Blatt.Copy
'Pfad und Dateiname
Datei = Pfad & Blatt.Name & Ext
'Blatt temporär speichern
If Dir(Datei) "" Then Kill Datei
With ActiveWorkbook
.SaveAs Datei
.Close
End With
'Senden
Call send_Email(Datei, Empf, "")
'Temp löschen
Kill Datei
End If
End Select
Next
End Sub
Private Sub send_Email(strDatei As String, strTo As String, strCc As String)
Dim olApp As Object, olMail As Object
Dim mbody As String
mbody = "Hallo Hier dein Dienstplan.
"
mbody = mbody & "
Gruß"
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
With olMail
.Subject = "Dienstplan"
.To = strTo
'.Cc = strCc
.htmlbody = mbody
.Attachments.Add strDatei
'.Display
.send 'je nach email- Sicherheitseinstellungen kann das einen Fehler 287 verursachen dann .Display
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
Private Sub send_Email(strDatei As String, strTo As String, strCc As String)
Dim olApp As Object, olMail As Object
Dim mbody As String
mbody = "Hallo <p><p> Hier dein Dienstplan.<p><p>"
mbody = mbody & "<p><p>Gruß"
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
With olMail
.Subject = "Dienstplan"
.To = strTo
'.Cc = strCc
.htmlbody = mbody
.Attachments.Add strDatei
.Display
'.send 'je nach Sicherheitseinstellungen kann das einen Fehler 287 verursachen dann .Display
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub