Vraag mbt VBA Excel

[XPlosive2019]

Goedemorgen,

In Excel wil ik iets gaan maken waarin punten komen te staan en als opmerkingen hyperlinks komen te staan (PDF).
Deze files staan in een map op de computer. Overigens staan er in die map ook nog andere mappen die niet meeverstuurd hoeven
te worden. Nu wil ik een knop maken in Excel die deze map incl. het Excelsheet inpakt in een .zip bestand en verstuurd
via outlook, is dat mogelijk?

Alvast bedankt!

 

[Timshel]

Deze code pakt bestanden in een map in en hecht de zip aan nieuwe mail.
Pas de mapnaam aan en run Zip_All_Files_in_Folder

Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

Sub Zip_All_Files_in_Folder()
    Dim FileNameZip, FolderName
    Dim strDate As String, DefPath As String
    Dim oApp As Object

    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    FolderName = [COLOR="#FF0000"]"P:\Downloads\"[/COLOR]    '<< Change

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    'Create empty Zip File
    NewZip (FileNameZip)

    Set oApp = CreateObject("Shell.Application")
    'Copy the files to the compressed folder
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items

    'Keep script waiting until Compressing is done
    On Error Resume Next
    Do Until oApp.Namespace(FileNameZip).items.Count = _
       oApp.Namespace(FolderName).items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0

    With CreateObject("Outlook.Application").CreateItem(0)
        .attachments.Add FileNameZip
        .Display
    End With
    Kill FileNameZip
End Sub