macro is traag

Sub mailoutlook()


If [Reparatieaanvraag!B3] = "" Then MsgBox "Je hebt geen korte beschrijving gegeven, in max 3 woorden, doe dit in cel B3 !                                                                                                                 Dit is nodig, want wat je hier invuld wordt meegenomen in de naam van het bestand !!!": Exit Sub
If [Reparatieaanvraag!C2] = "" Then MsgBox "Je hebt geen datum ingevuld,doe dit in cel C2 !": Exit Sub
If vbNo = MsgBox("Ben je wel zeker dat je die mail wil verzenden", vbYesNo) Then Exit Sub


'dit stukje vult de gegevens van blad 1 automatisch in op blad 2
Dim sh As Worksheet
Set sh = Sheets("reparatieaanvraag")
 With Sheets("openstaande reparaties")
   .Unprotect "0000"
   .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 5) = Array(sh.[AZ1], sh.[AY1], sh.[b3], sh.[b4], sh.[b5])
   .Protect "0000"
 End With


Sheets("Reparatieaanvraag").Range("B" & Rows.Count).End(xlUp).Offset(, 49).Value = Application.UserName

 pad = "G:\Pakketten\Everyone\Facilities\Reeds aangevraagd\" & Format(Sheets("Reparatieaanvraag").Range("AZ1"), "yyyy mm") & "\"
    Bst = "Reparatieaanvraag voor  " & Sheets("Reparatieaanvraag").[b3] & " " & Format(Sheets("Reparatieaanvraag").[AZ1], " DD MM YYYY  HH MM ") & ".xls"

    
    ActiveWorkbook.SaveAs Filename:=pad & Bst
    




  With CreateObject("Outlook.Application").createitem(olMailItem)
  .To = ""
  .cc = "test@test.be"
  .Subject = "Reparatie aanvraag   " & Sheets("Reparatieaanvraag").[b3] & " " & Format(Sheets("Reparatieaanvraag").[AZ1], "DD MM YYYY  HH MM") & ".xls"
  .body = Replace("Beste Hendrik,##Bij deze stuur ik u een excel file waar in vermeld staat welke reparatie uitgevoerd zou moeten worden, bij  . #Als je extra info hebt over het verder verloop van deze reparatie ,bv. wanneer ze deze komen uitvoeren of iets dergelijks , kan je deze mail dan beantwoorden aan iedereen ?#Zo is ineens iedereen op de hoogte van het verder verloop.#Als het nodig is dat dit bestand nog naar meer mensen moet worden gestuurd , geef dan even het mail adres door aan ##Met Vriendelijke Groeten## medewerker ###", "#", vbCr)
  .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
  .Send
  End With
  

  ActiveSheet.Unprotect Password:="0000"
 
  'dit stuk maakt de ingevulde velde terug leeg
   Range("B3,B4,B5,B2").Select
    Range("B5").Activate
    Selection.ClearContents
   
    'dit stukje verwijderd de foto's
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If Left(shp.Name, 3) <> "vst" Then shp.Delete
    Next shp
    
    ActiveSheet.Protect Password:="0000", DrawingObjects:=True, Contents:=True
    Range("B3").Select
    
    
    Application.DisplayAlerts = False
    
  ActiveWorkbook.SaveAs Filename:=("G:\Pakketten\Everyone\Facilities\Doorgeven van reparaties richting Hendrik .xls")
 
  MsgBox "De e - mail is correct verstuurd ", vbInformation
  
     ActiveWorkbook.Save
    ThisWorkbook.Saved = True
    Application.Quit
  
End Sub

bEvents = Application.EnableEvents
bUpdate = Application.ScreenUpdating
cCalc = Application.Calculation

Application.EnableEvents = false
Application.ScreenUpdating = false
Application.Calculation = xlCalculationManual

[REST van macro]

Application.EnableEvents = bEvents
Application.ScreenUpdating = bUpdate
Application.Calculation = cCalc
Application.Quit