Datei speichern unmöglich da VBA passwd geschützt

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Mldg As Byte
ActiveWorkbook.Unprotect ("123")
If ActiveWorkbook.Saved Then
Sheets("Error").Visible = True
For InI = Sheets.Count To 1 Step -1
If Sheets(InI).Name <> "Error" Then Sheets(InI).Visible = xlVeryHidden
Next InI
ByS = True
ThisWorkbook.Close True
Else
If ByS = True Then Exit Sub
Mldg = MsgBox(" Sollen die Veränderungen gespeichert werden ?", _
vbYesNo + vbQuestion, "Speicher abfrage ?", "", 0)
If Mldg = 6 Then        ' es wurde "Ja" gedrückt
Application.ScreenUpdating = False
Sheets("Error").Visible = True
For InI = Sheets.Count To 1 Step -1
If Sheets(InI).Name <> "Error" Then Sheets(InI).Visible = xlVeryHidden
Next InI
Application.ScreenUpdating = True
ByS = True
ThisWorkbook.Save
Else
ByS = True
ThisWorkbook.Close False
End If
End If
ActiveWorkbook.Protect ("123")
End Sub

Private Sub Workbook_Open()
If Year(Date) >= 2005 And Month(Date) >= 9 And _
((Day(Date) > 1 And Month(Date) = 9) Or Month(Date) > 9) Then
MsgBox "Ihre Testphase ist abgelaufen," _
& vbCr & "bitte wenden Sie sich an Ihren Administrator."
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ThisWorkbook.Close False
End If
ActiveWorkbook.Unprotect ("123")
Application.ScreenUpdating = False
For InI = Sheets.Count To 1 Step -1
Sheets(InI).Visible = True
Next InI
Sheets("Error").Visible = xlVeryHidden
Sheets("MS Car").Visible = xlVeryHidden
Sheets("variable-list").Visible = xlVeryHidden
ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
ActiveWorkbook.Protect ("123")
End Sub