Sub
Mail_Senden_mit_PDF()
Dim
WSh
As
Worksheet, WkS
As
Worksheet
Dim
sMailtext
As
String
, sBild
As
String
, sSignatur
As
String
Dim
sBer
As
String
, sDateiName
As
String
Dim
P
As
Integer
, iEinf
As
Integer
sDateiName = ThisWorkbook.FullName
sDateiName = Left$(sDateiName, InStrRev(sDateiName,
"."
)) &
"pdf"
ThisWorkbook.Sheets(
"Tabelle1"
).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sDateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=
True
, _
IgnorePrintAreas:=
False
, OpenAfterPublish:=
False
sBer =
"A20:K33"
Set
WSh = ThisWorkbook.Sheets(
"Tabelle1"
)
On
Error
Resume
Next
Do
WSh.Range(sBer).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
If
err.Number = 0
Then
Exit
Do
err.Clear
Loop
With
CreateObject(
"Outlook.Application"
).CreateItem(0)
.BodyFormat = 2
.Subject =
"Crate and Weight Size"
.
To
=
"Mail@test.de"
sMailtext =
"Hi ,"
& vbLf & vbLf &
"Crate and weight size for "
_
& WSh.Range(
"F20"
).Value &
":"
& vbLf & vbLf
.GetInspector: sSignatur = .HTMLBody
.HTMLBody = Replace(sMailtext, vbLf,
"<br>"
) & sSignatur
.Display
iEinf = Len(sMailtext) - 1
With
.GetInspector.WordEditor.Application.Selection
.Start = iEinf: .
End
= iEinf
.Paste
End
With
If
Dir$(sDateiName) <>
""
Then
.Attachments.Add sDateiName
End
If
End
With
End
Sub