Hi,
im new...and like all news need help
Have a code compiled from the Internet. So far so good, the code works great ... the only problem with this code is that the generated pdf file will not be inserted into the mail automatically.
Can someone help me with the code, to insert the pdf file automatically in the mail?
Modul:
---------------------------------------------------------------
Option Explicit
Sub RDB_Sheet_Level_Names_To_PDF_And_Create_Mail()
Dim FileName As String
Dim KolegaName, ArbeitsMonat As String
KolegaName = ThisWorkbook.Sheets("Jahresübersicht").Range("G2")
ArbeitsMonat = Month(CDate(ThisWorkbook.Sheets("Jahresübersicht").Range("F2"))) & "/" & Year(CDate(ThisWorkbook.Sheets("Jahresübersicht").Range("F2")))
'Call the function with the correct arguments
FileName = Create_PDF_Sheet_Level_Names(NamedRange:="addtopdf", _
FixedFilePathName:="Arbeitskarte.pdf", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
'For a fixed file name use this in the FixedFilePathName argument
'FixedFilePathName:="C:\Users\Niko\Test\YourPdfFile.pdf"
If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:="zeitabrechnung@mail.de", _
StrCC:="", _
StrBCC:="", _
StrSubject:="Zeitabrechnung" & " - " & "Arbeitsmonat: " & ArbeitsMonat & " - " & "Kolega: " & KolegaName & " - Gesendet: " & Date & " / " & Time, _
Signature:=True, _
Send:=False, _
StrBody:="<H3><B>Liebe Kolegen,</B></H3><br>" & _
"******>anbei die PDF datei mit der Zeitabrechnung." & _
"<br><br><br><br>Grüße,<br>" & _
"<br><br><br><br><br><br><br><br><br><br><br><br>" & "*Bitte Drücken Sie auf Senden und die Zeitabrechnung wird automatisch gesendet." & vbCrLf & "Vielen Dank."
Else
MsgBox "Das Erstellen einer PDF Datei war nicht möglich:" & vbNewLine & _
"Microsoft Add-in ist nicht installiert" & vbNewLine & _
"Sie haben den Speicher-Dialog abgebrochen" & vbNewLine & _
"Der Pfad zum Speichern der Datei ist nicht korrekt" & vbNewLine & _
"Sie wollten das vorhandene PDF nicht überschreiben, wenn es existiert"
End If
MsgBox "NICHT VERGESSEN!!!" & vbNewLine & "Drucken Sie den Arbeitsmonat aus.", vbInformation, "be healthy"
End Sub
Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
StrCC As String, StrBCC As String, StrSubject As String, _
Signature As Boolean, Send As Boolean, StrBody As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Signature = True Then .Display
.To = StrTo
.CC = StrCC
.BCC = StrBCC
.Subject = StrSubject
.HTMLBody = StrBody & "<br>" & .HTMLBody
.Attachments.Add FileNamePDF
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Function
Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
'This function will create a PDF with every sheet with
'a sheet level name variable <NamedRange> in it
Dim FileFormatstr As String
Dim Fname As Variant
Dim Ash As Worksheet
Dim sh As Worksheet
Dim ShArr() As String
Dim s As Long
Dim SheetLevelName As Name
'We fill the Array with sheets with the sheet level name variable
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = -1 Then
Set SheetLevelName = Nothing
On Error Resume Next
Set SheetLevelName = sh.Names(NamedRange)
On Error GoTo 0
If Not SheetLevelName Is Nothing Then
s = s + 1
ReDim Preserve ShArr(1 To s)
ShArr(s) = sh.Name
End If
End If
Next sh
'We exit the function If there are no sheets with
'a sheet level name variable named <NamedRange>
If s = 0 Then Exit Function
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
'Remember the ActiveSheet
Set Ash = ActiveSheet
'Select the sheets with the sheet level name in it
Sheets(ShArr).Select
'Now the file name is correct we Publish to PDF
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then
Create_PDF_Sheet_Level_Names = Fname
End If
Ash.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
---------------------------------------
Thx in advance
Nikko
im new...and like all news need help
Have a code compiled from the Internet. So far so good, the code works great ... the only problem with this code is that the generated pdf file will not be inserted into the mail automatically.
Can someone help me with the code, to insert the pdf file automatically in the mail?
Modul:
---------------------------------------------------------------
Option Explicit
Sub RDB_Sheet_Level_Names_To_PDF_And_Create_Mail()
Dim FileName As String
Dim KolegaName, ArbeitsMonat As String
KolegaName = ThisWorkbook.Sheets("Jahresübersicht").Range("G2")
ArbeitsMonat = Month(CDate(ThisWorkbook.Sheets("Jahresübersicht").Range("F2"))) & "/" & Year(CDate(ThisWorkbook.Sheets("Jahresübersicht").Range("F2")))
'Call the function with the correct arguments
FileName = Create_PDF_Sheet_Level_Names(NamedRange:="addtopdf", _
FixedFilePathName:="Arbeitskarte.pdf", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
'For a fixed file name use this in the FixedFilePathName argument
'FixedFilePathName:="C:\Users\Niko\Test\YourPdfFile.pdf"
If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:="zeitabrechnung@mail.de", _
StrCC:="", _
StrBCC:="", _
StrSubject:="Zeitabrechnung" & " - " & "Arbeitsmonat: " & ArbeitsMonat & " - " & "Kolega: " & KolegaName & " - Gesendet: " & Date & " / " & Time, _
Signature:=True, _
Send:=False, _
StrBody:="<H3><B>Liebe Kolegen,</B></H3><br>" & _
"******>anbei die PDF datei mit der Zeitabrechnung." & _
"<br><br><br><br>Grüße,<br>" & _
"<br><br><br><br><br><br><br><br><br><br><br><br>" & "*Bitte Drücken Sie auf Senden und die Zeitabrechnung wird automatisch gesendet." & vbCrLf & "Vielen Dank."
Else
MsgBox "Das Erstellen einer PDF Datei war nicht möglich:" & vbNewLine & _
"Microsoft Add-in ist nicht installiert" & vbNewLine & _
"Sie haben den Speicher-Dialog abgebrochen" & vbNewLine & _
"Der Pfad zum Speichern der Datei ist nicht korrekt" & vbNewLine & _
"Sie wollten das vorhandene PDF nicht überschreiben, wenn es existiert"
End If
MsgBox "NICHT VERGESSEN!!!" & vbNewLine & "Drucken Sie den Arbeitsmonat aus.", vbInformation, "be healthy"
End Sub
Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
StrCC As String, StrBCC As String, StrSubject As String, _
Signature As Boolean, Send As Boolean, StrBody As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Signature = True Then .Display
.To = StrTo
.CC = StrCC
.BCC = StrBCC
.Subject = StrSubject
.HTMLBody = StrBody & "<br>" & .HTMLBody
.Attachments.Add FileNamePDF
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Function
Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
'This function will create a PDF with every sheet with
'a sheet level name variable <NamedRange> in it
Dim FileFormatstr As String
Dim Fname As Variant
Dim Ash As Worksheet
Dim sh As Worksheet
Dim ShArr() As String
Dim s As Long
Dim SheetLevelName As Name
'We fill the Array with sheets with the sheet level name variable
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = -1 Then
Set SheetLevelName = Nothing
On Error Resume Next
Set SheetLevelName = sh.Names(NamedRange)
On Error GoTo 0
If Not SheetLevelName Is Nothing Then
s = s + 1
ReDim Preserve ShArr(1 To s)
ShArr(s) = sh.Name
End If
End If
Next sh
'We exit the function If there are no sheets with
'a sheet level name variable named <NamedRange>
If s = 0 Then Exit Function
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
'Remember the ActiveSheet
Set Ash = ActiveSheet
'Select the sheets with the sheet level name in it
Sheets(ShArr).Select
'Now the file name is correct we Publish to PDF
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then
Create_PDF_Sheet_Level_Names = Fname
End If
Ash.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
---------------------------------------
Thx in advance
Nikko
