excel active sheet als pdf verzenden

Theophiel · 31 dec 2016

hallo beste forumleden,

ik zou graag volgende code gebruiken maar in plaats dat alle werkbladen met een email adres in cel A1 verzonden worden zou enkel het actieve blad mogen verzonden worden naar het email adres van cel A1.

Code:

'Working only in 2007 and up
    Dim sh As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileName As String

    'Temporary path to save the PDF files
    'You can also use another folder like
    'TempFilePath = "C:\Users\Ron\MyFolder\"
    TempFilePath = Environ$("temp") & "\"

    'Loop through every worksheet
    For Each sh In ThisWorkbook.Worksheets
        FileName = ""

        'Test A1 for a mail address
        If sh.Range("A1").Value Like "?*@?*.?*" Then

            'If there is a mail address in A1 create the file name and the PDF
            TempFileName = TempFilePath & "Sheet " & sh.Name & " of " _
                         & ThisWorkbook.Name & " " _
                         & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

            FileName = RDB_Create_PDF(Source:=sh, _
                                      FixedFilePathName:=TempFileName, _
                                      OverwriteIfFileExist:=True, _
                                      OpenPDFAfterPublish:=False)

            'If publishing is OK create the mail
            If FileName <> "" Then
                RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
                                     StrTo:=sh.Range("A1").Value, _
                                     StrCC:="", _
                                     StrBCC:="", _
                                     StrSubject:="This is the subject", _
                                     Signature:=True, _
                                     Send:=False, _
                                     StrBody:="<H3><B>Dear Customer</B></H3><br>" & _
                                              "<body>See the attached PDF file with the last figures." & _
                                              "<br><br>" & "Regards Ron de bruin</body>"
            Else
                MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                       "Microsoft Add-in is not installed" & vbNewLine & _
                       "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                       "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                       "You didn't want to overwrite the existing PDF if it exist"
            End If

        End If
    Next sh
End Sub

ik loop steeds vast en had graag hulp bij het aanpassen.

Alvast bedankt op voorhand!

edmoor · 31 dec 2016

Probeer het zo maar eens. Je had niet de Sub regel geplaatst en die hoort er uiteraard wel bij:

Code:

Sub tst()
'Working only in 2007 and up
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileName As String

    'Temporary path to save the PDF files
    'You can also use another folder like
    'TempFilePath = "C:\Users\Ron\MyFolder\"
    TempFilePath = Environ$("temp") & "\"
    FileName = ""

    'Test A1 for a mail address
    If Range("A1").Value Like "?*@?*.?*" Then

        'If there is a mail address in A1 create the file name and the PDF
        TempFileName = TempFilePath & "Sheet " & ActiveSheet.Name & " of " _
                     & ThisWorkbook.Name & " " _
                     & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

        FileName = RDB_Create_PDF(Source:=ActiveSheet, _
                                  FixedFilePathName:=TempFileName, _
                                  OverwriteIfFileExist:=True, _
                                  OpenPDFAfterPublish:=False)

        'If publishing is OK create the mail
        If FileName <> "" Then
            RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
                                 StrTo:=Range("A1").Value, _
                                 StrCC:="", _
                                 StrBCC:="", _
                                 StrSubject:="This is the subject", _
                                 Signature:=True, _
                                 Send:=False, _
                                 StrBody:="<H3><B>Dear Customer</B></H3><br>" & _
                                          "<body>See the attached PDF file with the last figures." & _
                                          "<br><br>" & "Regards Ron de bruin</body>"
        Else
            MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                   "Microsoft Add-in is not installed" & vbNewLine & _
                   "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                   "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                   "You didn't want to overwrite the existing PDF if it exist"
        End If

    End If
End Sub

SjonR · 1 jan 2017

Edmoor,

Allereerst de beste wensen voor 2017.

Ik probeer de code ook werkend te krijgen en krijg een foutmelding.

Code:

  FileName = RDB_Create_PDF(Source:=sh, _
                                      FixedFilePathName:=TempFileName, _
                                      OverwriteIfFileExist:=True, _
                                      OpenPDFAfterPublish:=False)

De foutmelding verwijst naar RDB_Create_PDF en zegt dat de sub of function niet gedefinieerd is.

gast0660 · 1 jan 2017

Hoi
Beste wensen.
Zet deze in een module

Code:

Function RDB_Create_PDF(Source As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
If FixedFilePathName = "" Then
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If
        On Error Resume Next
        Source.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function

edmoor · 1 jan 2017

SjonR zei:
Allereerst de beste wensen voor 2017.
Ik probeer de code ook werkend te krijgen en krijg een foutmelding.
De foutmelding verwijst naar RDB_Create_PDF en zegt dat de sub of function niet gedefinieerd is.

Ook het beste gewenst.
Ik ging er vanuit dat je die functie al had omdat de rest ook bij Ron de Bruin vandaan komt.

Theophiel · 2 jan 2017

Dag forumleden,

m'n allerbeste wensen voor 2017.

Andermaal bedankt voor de aangeboden hulp! Ik ga morgen de code naar hartelust uitproberen.

Hartelijk bedankt.

Theophiel · 6 jan 2017

Hartelijk bedankt voor de aangeboden oplossing, werkt perfect!

excel active sheet als pdf verzenden

Theophiel

Gebruiker

edmoor

Inventaris

SjonR

Verenigingslid

gast0660

Terugkerende gebruiker

edmoor

Inventaris

Theophiel

Gebruiker

Theophiel

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy