Mailen - Outlook openen en sluiten

Sub opslaan_mailen()


'OPSLAAN
Sheets(5).Select

    sPad = Sheets("Instellingen").Range("C22")
    sTempPad = Split(sPad, "\")(0)
    
    Do Until Len(Dir(sPad, vbDirectory)) > 0
        i = i + 1
        sTempPad = sTempPad & "\" & Split(sPad, "\")(i)
        If Len(Dir(sTempPad, vbDirectory)) = 0 Then MkDir sTempPad
    Loop
    
Application.DisplayAlerts = False
Dim stPath As String
stPath = Sheets("Instellingen").Range("C22")
stPath = stPath & "\"

With CreateObject("Scripting.Filesystemobject")
    If Not .FolderExists(stPath) Then .CreateFolder stPath
    End With
    ActiveWorkbook.SaveAs filename:=stPath & Sheets("Instellingen").Range("C19") & ".xlsm"
Application.DisplayAlerts = True


'DOCUMENT VERZENDEN 
'Application.Dialogs(xlDialogSendMail).Show
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Formulier(en) " & Sheets("Instellingen").Range("C20")
        .Body = Sheets("Instellingen").Range("C27") 'standaard tekst in mail
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .display   'or use .Display or .Send (send is automatisch verzenden naar TO:"
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing


'document automatisch sluiten
If Workbooks.Count = 1 Then
ActiveWorkbook.Saved = True
Application.Quit
Else
ActiveWorkbook.Close False
End If

End Sub

Sub OpenOutlookFolder()
    Dim xOutlookApp As Outlook.Application
    Dim xNameSpace As Outlook.Namespace
    Dim xFolder As Outlook.Folder
    Dim xFolderType As OlDefaultFolders
    On Error Resume Next
    Set xOutlookApp = New Outlook.Application
    Set xNameSpace = xOutlookApp.Session
    Set xFolder = xNameSpace.GetDefaultFolder(olFolderInbox)
    xFolder.Display
    Set xFolder = Nothing
    Set xNameSpace = Nothing
    Set xOutlookApp = Nothing
    Exit Sub
End Sub