Option Explicit
Sub PDF_MailVB()
Dim rng As Excel.Range
Dim strMail As String
With Worksheets("Angebot").Columns("A")
Set rng = .Find("x", , xlValues, xlWhole, xlByColumns, MatchCase:=False)
If Not rng Is Nothing Then
strMail = rng.Offset(0, 1).Value
Dim name As String
Dim datei As String
datei = "Angebot_" & Mid(Date, 1, 2) & Mid(Date, 4, 2) & Mid(Date, 9, 2) & _
"_" & Mid(Time, 1, 2) & Mid(Time, 4, 2) & Mid(Time, 7, 2) & ".pdf"
name = ActiveWorkbook.Path + "\" + datei
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
name, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
Dim Empfänger As String, Betreff As String
Dim OutApp As Object, Mail As Object, i
Dim ClpObj As DataObject
Dim Nachricht
Empfänger = strMail
.Subject = "Angebot " & Date & " um " & Time
.Body = "Lieber Kunden," & vbCrLf & _
"vielen Dank für…….." & vbCrLf & _
"Mit freundlichen Grüssen" & vbCrLf & vbCrLf & _
"Chers clients," & vbCrLf & _
"Angebot" & vbCrLf & _
"Meilleures salutations" & vbCrLf & vbCrLf & _
"Cari clienti," & vbCrLf & _
"vielen Dank für….." & vbCrLf & _
"Sinceramente vostri"
.ReadReceiptRequested = False
.Attachments.Add name
.Display
End With
Set olApp = Nothing
End If
End With
End Sub