Option
Explicit
Sub
Versenden()
Dim
strPath
As
String
Dim
strFile
As
String
Dim
strFull
As
String
Dim
strBetr
As
String
Dim
strAnhg
As
String
Dim
StrEmpf
As
String
Dim
strText
As
String
On
Error
GoTo
errh
strPath = Sheets(
"Tabelle4"
).Range(
"K4"
).Value
If
Right(strPath, 1) <>
"\" Then strPath = strPath & "
\"
strFile = Sheets(
"Tabelle4"
).Range(
"K14"
).Value
If
Right(strFile, 4) <>
".pdf"
Then
strFile = strFile &
".pdf"
strFull = strPath & strFile
Application.ScreenUpdating =
False
Application.DisplayAlerts =
False
Sheets(Array(
"Tabelle1"
,
"Tabelle2"
,
"Tabelle3"
)).Copy
Sheets(Array(
"Tabelle1"
,
"Tabelle2"
,
"Tabelle3"
)).
Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFull, _
Quality:=xlQualityStandard, IncludeDocProperties:=
True
, _
IgnorePrintAreas:=
False
, OpenAfterPublish:=
False
ActiveWindow.Close
False
strBetr = Sheets(
"Tabelle4"
).Range(
"K12"
).Value
strAnhg = strFull
StrEmpf = Sheets(
"Tabelle4"
).Range(
"K10"
).Value
strText =
""
CDO_Mail_Versand strBetr, strAnhg, StrEmpf, strText, _
Sheets(
"Tabelle4"
).Range(
"K16"
).Value, _
Sheets(
"Tabelle4"
).Range(
"K18"
).Value
On
Error
GoTo
0
errh:
If
Err.Number = 0
Then
MsgBox
"Erfolgreich!"
Application.DisplayAlerts =
True
Application.ScreenUpdating =
True
End
Sub
Private
Sub
CDO_Mail_Versand(
ByVal
BETR
As
String
, _
ByVal
ANH
As
String
,
ByVal
EMPF
As
String
,
ByVal
MTEXT
As
String
, _
ByVal
ADDI
As
String
, SENDER
As
String
)
Dim
iMsg
As
Object
Dim
iConf
As
Object
Dim
strbody
As
String
Dim
Flds
As
Variant
Set
iMsg = CreateObject(
"CDO.Message"
)
Set
iConf = CreateObject(
"CDO.Configuration"
)
iConf.Load -1
Set
Flds = iConf.Fields
With
Flds
.Update
End
With
strbody = MTEXT
With
iMsg
Set
.Configuration = iConf
.
To
= EMPF
.CC =
""
.BCC =
""
.From = SENDER
.Subject = BETR
.TextBody = strbody
.AddAttachment ANH
.Send
End
With
End
Sub