Pdf versturen per mail vanuit Listbox

[Danny09]

Mijn vraag:

Gebruikte software Excel 2016

Een tabblad in pdf versturen per mail door middel van een Listbox.

Tot nu toe heb ik twee buttons gemaakt, waarvan de eerste (Private Sub CmdPrintPDF_Click goed werkt. De button Private Sub Sendpdfbymail_Click() werkt ook maar alleen als ik op het juiste tabblad sta en dus niet met de keuzelijst. Het zou handig zijn, mocht dit ook kunnen via de Listbox.

Wie kan mij hierbij helpen?
-------------------------------------------------------------------------------------------------------------------------------------------------
Relevante software en hardware die ik gebruik

Gebruikte software Excel 2016
-------------------------------------------------------------------------------------------------------------------------------------------------
Wat ik al gevonden of geprobeerd heb

code:

Private Sub CmdPrintPDF_Click()
Dim iloop As Integer
Dim ftst As Variant
ftst = Sheets("Rijtijden Jan").Range("A1").Value
For iloop = 1 To ListBox1.ListCount
 If ListBox1.Selected(iloop - 1) = True Then
   Sheets(ListBox1.List(iloop - 1, 0)).ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
    ftst & ListBox1.List(iloop - 1, 0), Quality:=xlQualityStandard, IncludeDocProperties:= _
    True, IgnorePrintAreas:=False, OpenAfterPublish:=True
   ListBox1.Selected(iloop - 1) = False
 End If
 Next
End Sub

-------------------------------------------------------------------------------------------------------------------------------------------------

code:

Private Sub Sendpdfbymail_Click()
'Do not forget to change the email ID
'before running this code

    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFullPath As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.

    TempFilePath = Environ$("temp") & "D:\Documents\Rijtijden Bus"

' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.

    TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

'Complete path of the file where it is saved
    FileFullPath = "D:\Documents\Rijtijden Bus" & TempFileName

'Now Export the Activessheet as PDF with the given File Name and path

    On Error GoTo err
    With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With

'Now open a new mail

    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)

    On Error Resume Next
    With NewMail
        .To = "xxxxxxxxxxx@xxxxxxxxxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Prestatieblad"
        .Body = ""
        .Attachments.Add FileFullPath '--- full path of the pdf where it is saved
        .Display   'or use .Send to show you the email before sending it.
    End With
    On Error GoTo 0

'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder

    Kill FileFullPath

'set nothing to the objects created
    Set NewMail = Nothing
    Set OlApp = Nothing

'Now set the application properties back to true
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox ("Email Succesvol verstuurd")
    Exit Sub
err:
        MsgBox err.Description
End Sub

-------------------------------------------------------------------------------------------------------------------------------------------------

[Bolukan]

Je savet de pdf's als

code:

Sheets("Rijtijden Jan").Range("A1").Value & ListBox1.List(iloop - 1, 0)

en bij het versturen gebruik je

code:

"D:\Documents\Rijtijden Bus" & ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

Krijg je dan wel dezelfde bestandsnamen?

[Danny09]

Mag ik u vragen, de code op de juiste plaats te zetten? Ik krijg dit niet voor elkaar.
-----------------------------------------------------------------------------------------------------------------------------------

code:

Private Sub Sendpdfbymail_Click()
'Do not forget to change the email ID
'before running this code

    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFullPath As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.

    TempFilePath = Environ$("temp") & "D:\Documents\Rijtijden Bus"

' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.

    TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

'Complete path of the file where it is saved
    FileFullPath = "D:\Documents\Rijtijden Bus" & TempFileName

'Now Export the Activessheet as PDF with the given File Name and path

    On Error GoTo err
    With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With

'Now open a new mail

    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)

    On Error Resume Next
    With NewMail
        .To = "xxxxxxxxxxxxxxxxxxx@xxxxxxxxxxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Prestatieblad"
        .Body = ""
        .Attachments.Add FileFullPath '--- full path of the pdf where it is saved
        .Display   'or use .Send to show you the email before sending it.
    End With
    On Error GoTo 0

'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder

    Kill FileFullPath

'set nothing to the objects created
    Set NewMail = Nothing
    Set OlApp = Nothing

'Now set the application properties back to true
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox ("Email Succesvol verstuurd")
    Exit Sub
err:
        MsgBox err.Description
End Sub

[Creepy]

Eh nee. Dat mag je hier niet vragen. Het draait hier om zelf programmeren . Niet om anderen dat voor je te laten doen. Werving in welke vorm dan ook is hier niet toegestaan.