Private Sub Workbook_BeforeClose(Cancel As Boolean)
'macro versie 17-05-2018
Select Case ThisWorkbook.BuiltinDocumentProperties("Last Author") 'Controle of je schrijfbevoegd bent
Case "Gierman, Frank", _
"Laurman, Kees", _
"Extra naam"
Select Case MsgBox("Meneer Laurman, wil je het bestand opslaan voordat je het sluit?", vbYesNoCancel, "Opslaan") '3 keuze box openen, "Ja/Nee/Annuleren"
Case Is = vbYes 'Wanneer "Ja", opslaan op de locaties hieronder
Worksheets("Fouten").Visible = True
Application.DisplayAlerts = False
Dim Count As Long, i As Long
Dim CountTot As Long
Dim Sectie As String
Dim Locatie As String
On Error GoTo Foutje
Sectie = "Map1"
Locatie = "H:\map1\" & ActiveWorkbook.Name
SetAttr Locatie, vbNormal 'Maak hier een Normal van
ActiveWorkbook.SaveAs Locatie
SetAttr Locatie, vbReadOnly 'Maak hier een ReadOnly van
Count = 0
Sectie = "Map2"
Locatie = "H:\map2\" & ActiveWorkbook.Name
ActiveWorkbook.SaveAs Locatie
Worksheets("Fouten").Visible = False
If CountTot = 0 Then
MsgBox "Opslag gelukt op alle locaties." & vbNewLine & vbNewLine & "Bestand wordt afgesloten.", vbOKOnly, "Opslaan"
Application.Quit
Exit Sub
End If
If CountTot < 4 Then
MsgBox "Er zijn in totaal " & CountTot & " fouten geweest tijdens het opslaan.", vbOKOnly, "Opslaan"
Application.Quit
End If
If CountTot = 4 Then
Select Case MsgBox("In totaal zijn er " & CountTot & " fouten geweest tijdens het opslaan." & vbNewLine & vbNewLine & _
"Er is niks opgeslagen!!! Klik 'Ja' en probeer via 'Opslaan als' het bestand ergens anders op te staan." & vbNewLine & vbNewLine & _
"Bij 'Nee' wordt het bestand afgesloten!", vbYesNo, "Opslaan mislukt!")
Case Is = vbYes 'Wanneer "Ja", terug naar bestand
Cancel = True
Case Is = vbNo 'Wanneer "Nee", afsluiten zonder opslaan
Application.Quit
Exit Sub
End Select
End If
Application.DisplayAlerts = False
Exit Sub 'Afsluiten bestand na het opslaan
Case Is = vbCancel 'Wanneer "Annuleren", terug naar bestand
Cancel = True
Case Is = vbNo 'Wanneer "Nee", afsluiten zonder opslaan
Application.DisplayAlerts = False
Application.Quit
Exit Sub 'Afsluiten "ingeval van gebruiker..."
End Select
Exit Sub
End Select
If ThisWorkbook.ReadOnly Then
Select Case MsgBox("Bestand wordt gesloten, opslaan is niet mogelijk! " _
& vbNewLine & vbNewLine & "Klik Ok om af te sluiten zonder op te slaan." & vbNewLine & "" _
& vbNewLine & "Klik annuleren en kies 'Opslaan als' om een persoonlijk bestand te maken." & vbNewLine & "", vbOKCancel, "ReadOnly bestand") 'Igv ReadOnly bestand deze POP-up
Case Is = vbCancel
Cancel = True
Case Is = vbOK 'Wanneer "Ok", afsluiten zonder opslaan
Application.DisplayAlerts = False
Application.Quit
End Select
End If
Select Case MsgBox("Bestand wordt gesloten, opslaan is niet mogelijk! " _
& vbNewLine & vbNewLine & "Klik Ok om af te sluiten zonder op te slaan." & vbNewLine & "" _
& vbNewLine & "Klik annuleren en kies 'Opslaan als' om een persoonlijk bestand te maken." & vbNewLine & "", vbOKCancel, "ReadOnly bestand") 'Indien je niet gebruiker ... bent deze POP-up
Case Is = vbCancel
Cancel = True
Case Is = vbOK 'Wanneer "Ok", afsluiten zonder opslaan
Application.DisplayAlerts = False
Application.Quit
Exit Sub
End Select
Foutje:
Count = Count + 1
CountTot = CountTot + 1
With Sheets("Fouten") 'fout registratie in tabblad fouten
rij = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(rij, 1) = Err.Number
.Cells(rij, 2) = Err.Description
.Cells(rij, 3) = Now()
.Cells(rij, 4) = Environ("username")
.Cells(rij, 5) = Sectie
.Cells(rij, 6) = Count
End With
If Count = 1 Then
MsgBox "Er ging iets niet goed met opslaan: " & vbNewLine & vbNewLine & "Opslag niet gelukt in map van " & Sectie & ".", vbCritical, "Fout"
End If
Resume Next
End Sub