AW: Emailversand durch Userform
12.07.2019 10:10:40
Marco
Hallo,
auch wenn es sonst nicht meine Art ist aber ich weiß dass die Frage hier häufiger auftaucht und auch weil ich etwas ähnliches(nur umfangreicher) schon selbst nutze - anbei Dein Makro. :-)
Hier wird jeweils nur eine Ausgewählte Seite und Grund genommen - Rest wird ignoriert. Eine Lösung mit mehrfachauswahl ist schon etwas aufwändiger.
Bitte lies Dir die Kommentare genau durch bevor Du Fragen hast. Ansonsten bin ich bis heute Mittag noch erreichbar und danach erst einmal im Urlaub :-)
VG
Marco
Private Sub CommandButton1_Click()
Dim empfaengermail As String
Dim empfaengeranrede As String
Dim betreff As String
Dim ersteller As String
Dim kollektion As String
Dim grund As String
Dim bemerkung As String
Dim TempVerzeichnis As String
Dim PDFDatei As String
Dim olApp As Outlook.Application
Dim olNameSpace As Namespace
Dim objMailItem As MailItem
Dim objFolder As MAPIFolder
Dim mailtext As String
TempVerzeichnis = Environ("TEMP") & "\" 'Erkennt das Temporäre Verzeichnis
ersteller = ComboBox1.Value
bemerkung = TextBox1.Value
Application.ScreenUpdating = False
'Empfaenger und Anrede nach Kollektion festlegen - Hier noch die # entfernen
If CheckBox11.Value = True Then
kollektion = "Frühling"
empfaengermail = "mail1@test.de;mail2@test.de;"
empfaengeranrede = "Sehr geehrter Herr...Sehr geehrte Frau..."
ThisWorkbook.Sheets("Frühling").Activate
End If
If CheckBox7.Value = True Then
kollektion = "Sommer"
empfaengermail = "mail1@test.de;mail2@test.de"
empfaengeranrede = "Sehr geehrter Herr...Sehr geehrte Frau..."
ThisWorkbook.Sheets("Sommer").Activate
End If
If CheckBox12.Value = True Then
kollektion = "Herbst"
empfaengermail = "mail1@test.de;mail2@test.de"
empfaengeranrede = "Sehr geehrter Herr...Sehr geehrte Frau..."
ThisWorkbook.Sheets("Herbst").Activate
End If
If CheckBox8.Value = True Then
kollektion = "Winter"
empfaengermail = "mail1@test.de;mail2@test.de"
empfaengeranrede = "Sehr geehrter Herr...Sehr geehrte Frau..."
ThisWorkbook.Sheets("Winter").Activate
End If
'Grund für Empfänger festlegen
If CheckBox5.Value = True Then grund = "Nachfrage"
If CheckBox1.Value = True Then grund = "Preisänderung"
If CheckBox6.Value = True Then grund = "Kollektionsänderung"
If CheckBox2.Value = True Then grund = "Sonstiges"
'Prüfung ob Kollektion und Grund ausgewählt wurden oder Messagebox
If kollektion = "" Or grund = "" Then
MsgBox "Bitten wählen Sie Kollektion und Grund aus", vbInformation & vpokonly, "Angaben _
fehlerhaft"
End If
'Export der Ausgewählten Tabelle als PDF für Anhang der Email
PDFDatei = TempVerzeichnis & kollektion & "_" & grund & "_" & ersteller & "_" & Format(Date, " _
DDMMYYYY") & ".pdf"
ActiveSheet.ExportAsFixedFormat xlTypePDF, PDFDatei, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=True, OpenAfterPublish:=False
'Inhalt und Betreff der Email erstellen - Hier noch die # entfernen
betreff = kollektion & " " & grund & " " & ersteller
mailtext = empfaengeranrede & ""
mailtext = mailtext & "Hier Dein Text der in der Email stehen soll" & ""
If bemerkung "" Then mailtext = mailtext & "Bemerkung:
" & bemerkung & ""
mailtext = mailtext & "Mit freundlichen Grüßen
Name"
'Email erstellen und versenden
'Microsoft Outlook 14 Objekt Library muss in Verweisen aktiviert sein (VBA-Editor/extras/ _
verweise)
Set olApp = CreateObject("Outlook.Application")
Set olNameSpace = olApp.GetNamespace("MAPI")
Set objFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set objMailItem = objFolder.Items.Add(olMailItem)
With objMailItem
.To = empfaengermail
.Subject = betreff
.HTMLBody = mailtext
.Attachments.Add PDFDatei
.Display
End With
olApp.ActiveWindow
SendKeys "%s"
Kill PDFDatei 'PDF-Datei nach Versand löschen
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Activate()
Application.ScreenUpdating = False
Sheet2.Activate
ersteller = Range("C2:C5")
ComboBox1.List = ersteller
Sheet1.Activate
Application.ScreenUpdating = True
End Sub