AW: VBA Password
17.09.2010 19:04:37
Nepumuk
Hallo Serge,
ich denke, du hast mich nicht verstanden. Darum habe ich dir mal ein Beispiel gemacht:
Option Explicit
Private Const PASS_WORD = "Password"
Public Sub Change_Password()
Dim objName As Name, objSheet As Object
Dim blnFound As Boolean
Dim strOldPassword As String, strConfirmation As String
Dim strInput1 As String, strInput2 As String
Dim intCounter As Integer
'Altes Kennwort suchen
For Each objName In ThisWorkbook.Names
If objName.Name = PASS_WORD Then
blnFound = True
Exit For
End If
Next
'Kennwort gefunden User muss das alte Kennwort bestätigen
If blnFound Then
strOldPassword = Split(ThisWorkbook.Names(PASS_WORD).Value, Chr$(34))(1)
Do
intCounter = intCounter + 1
strConfirmation = InputBox("Bitte altes Kennwort eingeben.", "Eingabe")
If StrPtr(strConfirmation) = 0 Then Exit Sub
If strConfirmation = strOldPassword Then
Exit Do
Else
If intCounter = 3 Then Exit Sub
MsgBox "Falsche Eingabe. Noch " & CStr(3 - intCounter) & " Versuch" & _
IIf(intCounter = 1, "e", "") & ".", vbExclamation, "Hinweis"
End If
Loop
End If
'Neues Kennwort eingeben
Do
strInput1 = InputBox("Bitte neues Kennwort eingeben.", "Eingabe")
If StrPtr(strInput1) = 0 Then Exit Sub
If strInput1 <> vbNullString Then
If Len(strInput1) <= 15 Then
If Len(strInput1) >= 8 Then
If strInput1 <> strOldPassword Then
Exit Do
Else
MsgBox "Das alte und das neue Kennwort ist identisch.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Bitte mindestens 8 Zeichen eingeben.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Bitte maximal 15 Zeichen eingeben.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Bitte geben Sie das neue Kennwort ein.", vbExclamation, "Hinweis"
End If
Loop
'Neues Kennwort bestätigen
Do
strInput2 = InputBox("Bitte neues Kennwort wierderholen.", "Eingabe")
If StrPtr(strInput2) = 0 Then Exit Sub
If strInput1 = strInput2 Then
Exit Do
Else
MsgBox "Die Wiederholung entspricht nicht der ersten Eingabe.", vbExclamation, "Hinweis"
End If
Loop
'Blattschutz für alle Sheets aufheben
If blnFound Then
For Each objSheet In ThisWorkbook.Sheets
Call Unprotect_Sheet(objSheet)
Next
End If
'Neues Kennwort speichern
ThisWorkbook.Names.Add Name:=PASS_WORD, RefersTo:=strInput2, Visible:=False
'Blattschutz für alle Sheets neu setzen
For Each objSheet In ThisWorkbook.Sheets
Call Protect_Sheet(objSheet)
Next
'Mappe speichern
ThisWorkbook.Save
'Objekte freigeben
Set objName = Nothing
Set objSheet = Nothing
End Sub
Public Sub Protect_Sheet(objSheet As Object)
objSheet.Protect Password:=Split(ThisWorkbook.Names(PASS_WORD).Value, Chr$(34))(1)
End Sub
Public Sub Unprotect_Sheet(objSheet As Object)
objSheet.Unprotect Password:=Split(ThisWorkbook.Names(PASS_WORD).Value, Chr$(34))(1)
End Sub
Wenn du das ganze zum ersten mal benutzt, musst du den Schutz für alle Tabellen vorher manuell aufheben !!!
Dann musst du in den Mappen überall wo eine Tabelle geschützt oder der Schutz aufgehoben wird Befehle wie:
ActiveSheet.UnProtect "DeinKennwort" bzw. ActiveSheet.Protect "DeinKennwort"
durch den Aufruf:
Call Unprotect_Sheet(ActiveSheet) bzw. Call Protect_Sheet(ActiveSheet)
ersetzen.
Dann benötigst du noch einen Button in einer Tabelle oder einen Menübutton mit welcher der User die Prozedur "Change_Password" aufrufen kann.
Gruß
Nepumuk