VBA Schutz einfügen und Schließen geht nicht

Sub BlattSpeichern()
Dim TBName$, WBName$
Dim tan
tan = ActiveSheet.Name
TBName = InputBox("Blattname:", "Datei erstellen", tan)
If TBName = "" Then Exit Sub
WBName = InputBox("Dateiname übernehmen oder ändern ?", _
"Dateinamen erstellen", tan & "  vom  " & Format(Date, "YYYY.MM.DD") & ".xls")
If WBName = "" Then Exit Sub
Worksheets(TBName).Copy
'--- so jetzt noch ins Verzeichnis speichern -------------
Dim Fs As Object, OrdNam As Variant, Ord As Byte, Pfad As String
Dim DateiNam As String
DateiNam = WBName
On Error Resume Next
OrdNam = Split("C:\Werkstatt\Muster\Teile", "\")
Pfad = OrdNam(0) & "\"
ChDrive Left(OrdNam(0), 1)
For Ord = 1 To UBound(OrdNam)
ChDir Pfad
Set Fs = CreateObject("Scripting.FileSystemObject")
If Not Fs.folderexists(Pfad & OrdNam(Ord)) Then
MkDir OrdNam(Ord)
MsgBox "Der Ordner " & vbLf & vbLf & Pfad & OrdNam(Ord) & _
vbLf & vbLf & " wurde erstellt.                                  "
Else
' MsgBox "Der Ordner " & vbLf & vbLf & Pfad & _
'         OrdNam(Ord) & vbLf & vbLf & " existiert bereits.                 "
End If
Pfad = Pfad & OrdNam(Ord) & "\"
Next Ord
Set Fs = Nothing
MsgBox "Ordner:   " & Pfad & "              ist vorhanden !    " & Chr(13) _
& Chr(13) & "   Datei:  " & "          " & DateiNam & "             " _
& "     wird jetzt gespeichert !    ", vbInformation, " Hinweis !"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Pfad & DateiNam, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
'----- jetzt schutz setzen --------------
Dim akw As String
akw = ActiveWorkbook.Name
Dim Password As String
Password = "wwpawb"
Dim wb As Workbook, ok As Boolean, s As String
Set wb = Application.Workbooks(akw)
SendKeys "%{F11}^r{Tab}", True
Do While Application.VBE.ActiveVBProject.Filename  wb.FullName
''Cursor im Projekt-Explorer-Fenster auf das nächste Projekt setzen _
bis er auf dem aktuelle Projekt der zu entschützenden Arbeitsmappe steht
SendKeys "{Tab}", True
Loop
If Not ActiveWorkbook.VBProject.Protection Then
' Application.DisplayAlerts = False
' Application.ScreenUpdating = False
SendKeys "%xi"                          'damit Passwort
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{RIGHT}"
SendKeys "{TAB}"
SendKeys " "                         'für Leertaste
SendKeys "{TAB}"
SendKeys Password
SendKeys "{TAB}"
SendKeys Password
SendKeys "{TAB}"
SendKeys "{Enter}"
SendKeys "%{F11}"
End If
' MsgBox "Der VBA Schutz ist eingefügt !        "
'ActiveWorkbook.Close
End Sub

mfg Kurt P