Datei Auswahl für E-Mail Anhang

Sub ExportSendAsPDF()
Dim str_pdfname As String
Dim bool_pdfmsgbox As Boolean
Dim str_path As String
Dim str_date_name As String
Dim str_ws_name As String
Dim str_ask_text As String
Dim str_ask_header As String
Dim str_quest_text As String
Dim str_quest_header As String
Dim str_save_quest As String
Dim str_save_header As String
Dim str_check_text As String
Dim str_check_header As String
Dim objApp As Object
Dim objMailItem As Object
Dim sDatei As String
Dim email_1 As String
Dim email_2 As String
Dim email_3 As String
'DEFINITION DER BENÖTIGTEN TEXTE !
'Header der Fragestellung
str_ask_header = ActiveSheet.Name
'Fragestellung zum Speichern Dynmaisch
str_ask_text = "Möchten sie die Datei nach dem Speichern anzeigen lassen ?"
'Aussage nach dem Speichern
str_quest_text = ActiveSheet.Name & " wurde gespeichert"
'Gespeichert Header
str_quest_header = ActiveSheet.Name
'Definition der Fragestellung zum Speichern
str_save_quest = "Möchten sie die Datei Speichern ?"
'Definitionder des Headers zur Speicherfrage
str_save_header = "Speichern?"
'Definition des Abbruchtextes
str_check_text = "Es wurden nicht alle Pflichtfelder ausgefüllt."
'Definition Header - Check
str_check_header = "Nicht vollständig!"
'Check ob alle Felder ausgefüllt wurden
If ActiveSheet Is Sheets("FFZ-Schaden") Then
If Range("B52") = "Bitte füllen sie alle Pflichtfelder aus !" Then
MsgBox str_check_text, vbOKOnly, str_check_header
Exit Sub
End If
End If
If ActiveSheet Is Sheets("Gebäudeschaden") Then
If Range("B42") = "Bitte füllen sie alle Pflichtfelder aus !" Then
MsgBox str_check_text, vbOKOnly, str_check_header
Exit Sub
End If
End If
If ActiveSheet Is Sheets("Materialschaden") Then
If Range("B42") = "Bitte füllen sie alle Pflichtfelder aus !" Then
MsgBox str_check_text, vbOKOnly, str_check_header
Exit Sub
End If
End If
'DEFINITION DER ORDNER FÜR DIE SPEICHERUNG !
'Prüfen ob die Datei gepseichert werden soll
If MsgBox(str_save_quest, vbYesNo, str_save_header) = vbNo Then
Exit Sub
End If
'Definition der Ordner zur erstellung selbigem Namens
str_path = ThisWorkbook.Path
str_ws_name = ActiveSheet.Name
'Anlegen des Ordners - "Schadensmeldung" wenn im selben Verzeichnis noch nicht vorhanden.
If Dir(str_path & "\" & str_ws_name, vbDirectory) = "" Then
MkDir (str_path & "\" & str_ws_name)
End If
' Ordner erstellen wenn noch nicht vorhanden.
If Dir(str_path & "\" & str_ws_name & "\" & Range("F7"), vbDirectory) = "" Then
MkDir (str_path & "\" & str_ws_name & "\" & Range("F7"))
End If
' Checken ob die Datei nach dem Speichern geöffnet werden soll .
' If MsgBox(str_ask_text, vbYesNo, str_ask_header) = vbYes Then bool_pdfmsgbox = True
' Dateipfad bestimmung in Relation zum Datum
str_pdfname = str_path & "\" & str_ws_name & "\" & Range("F7") & "\" & Range("F17") & "_" &  _
Format(Now, "DD.MM.YY") & "_" & Range("O12") & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=str_pdfname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'IIf(pdfmsgbox, True, False)
Load email_form
email_form.Show
With email_form
email_1 = email_form.ComboBox1.Value
email_2 = email_form.ComboBox2.Value
email_3 = email_form.ComboBox3.Value
Unload email_form
End With
On Error GoTo Errorhandler
Set objApp = CreateObject("Outlook.Application")
Set objMailItem = objApp.CreateItem(0)
With objMailItem
.to = email_1 & "; " & email_2 & "; " & email_3
.Subject = "F 88 Schadensmeldung - " & str_ws_name
.Attachments.Add str_pdfname
.Display
'.send
End With
Aufräumen:
Set objMailItem = Nothing
Set objApp = Nothing
Exit Sub
Errorhandler:
On Error GoTo 0
MsgBox "Fehler beim Erstellen der Email.", vbCritical, "Fehler"
GoTo Aufräumen
End Sub