1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
| Private Sub Btn_99_Druckausgabe_Email_Click()
'Date$ liefert MM-TT-YYY. Die Bindestriche müssen raus
datum = Mid(Date$, 7, 4) & Left(Date$, 2) & Mid(Date$, 4, 2)
Set Applic = Application.ActiveWorkbook 'Merken der Tool-Application
MSG = Range("M_MAIL_ADR")
Mailadress = InputBox(MSG, "Email Adress")
Dim x
x = InStr(1, Mailadress, "@")
MSG4 = Range("M_MAIL_ERR")
If Mailadress = "" Or x = 0 Then
MsgBox (MSG4)
Exit Sub
End If
test = Mailadress
'=============================================================================
Dim FileSaveName 'Pfad und Dateiname der zu sichernden Datei
empfaenger = Range("Z_Titelblatt_Kunde")
FileSaveName = Application.GetSaveAsFilename _
(InitialFileName:=pfad & "\Checkliste_" & empfaenger & "_" & datum, _
FileFilter:="EXCEL-Tabelle (*.xls), *.xls ,pdf datei (*.pdf),*.pdf")
If FileSaveName <> False Then
Select Case LCase$(Right$(FileSaveName, 3))
Case "xls"
ActiveSheet.SaveAs Filename:=FileSaveName
Case "pdf"
'deine Druckroutine für PDF
ActiveSheet.SaveAs Filename:=FileSaveName, _
Password:=""
End Select
End If
On Error Resume Next 'Fehlerausgang, Weiter mit Löschen, wenn EMail abgelehnt wurde
ActiveWorkbook.SendMail Recipients:=Mailadress
MSG1 = Range("M_MAIL1")
MSG2 = Range("M_MAIL2")
MSG3 = Range("M_MAIL3")
MsgBox (MSG1 & Chr(13) _
& "Checkliste_" & empfaenger & "_" & datum & Chr(13) _
& MSG2 & Chr(13) _
& Mailadress & Chr(13) _
& MSG3)
End Sub |
Partager