Dim Today, FolderName$, DateValue$, NameofFile$, FullFileName$
   FolderName$ = "D:\Dagafsluitrapport\Wilrijk\" + DatePart('yyyy', Date) + "\\" + MonthName(Month(Date)) + "\\"
   DateValue$ = Format(Now, "yy-mm-dd")
   NameofFile$ = "dagafsluitrapport"
   FullFileName$ = FolderName$ + DateValue$ + " " + NameofFile$
   ActiveDocument.SaveAs FileName:=FullFileName$, FileFormat:=wdFormatDocument


Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim ddate As Date

ddate = Date


On Error Resume Next

If Len(ActiveDocument.Path) = 0 Then
    MsgBox "Document needs to be saved first"
    Exit Sub
End If

Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
    bStarted = True
End If

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem
    .To = "[email protected]"
    .Subject = "Dagrapport" + " " & ddate
    'Add the document as an attachment, you can use the .displayname property
    'to set the description that's used in the message
    .Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue, _
      DisplayName:="Document as attachment"
    .Send



End With

ActiveWindow.Close SaveChanges:=wdDoNotSaveChanges


If bStarted Then
    oOutlookApp.Quit
End If

Set oItem = Nothing
Set oOutlookApp = Nothing
Application.Quit

End Sub