AW: Schreibschutz durch Makro aufheben
08.12.2006 15:20:51
Matthias
Hallo Bernd,
nicht ganz das, was du möchtest, aber mit ähnlicher Funktionalität:
- erstelle ein Blatt namens "Warnung" (wenn du es anders nennen willst, musst du den Namen im u.a. Code anpassen
- gestalte das Blatt so, dass eine Info draufsteht, dass die Mappe mit deaktivierten Makros nicht funktioniert.
- kopiere folgenden Code ins Modul DieseArbeitsmappe:
Option Explicit
Const OhneMakros = "Warnung" 'Name des Blattes mit der Info
Const pwWarnung = "12345" 'Kennwort des Blattes mit der Info
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Saved = False Then
Select Case MsgBox("Sollen Ihre Änderungen in '" & Me.Name & "' gespeichert werden?", vbYesNoCancel + vbExclamation)
Case vbYes
Speichern
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
End Select
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
If SaveAsUI Then
MsgBox "Speichern unter... nicht möglich!" 'müsste falls erforderlich noch erweitert werden
Else
Speichern
End If
End Sub
Private Sub Workbook_Open()
AllesEinblenden
On Error Resume Next
'beim Speichern gemerktes aktives Blatt anzeigen:
Sheets(Sheets(OhneMakros).Cells(Rows.Count, Columns.Count).Value).Activate
Me.Saved = True
End Sub
Private Sub AllesAusblenden()
Dim sh As Worksheet
Sheets(OhneMakros).Visible = True
For Each sh In Me.Worksheets
If sh.Name <> OhneMakros Then sh.Visible = xlSheetVeryHidden
Next sh
End Sub
Private Sub AllesEinblenden()
Dim sh As Worksheet
For Each sh In Me.Worksheets
sh.Visible = True
Next sh
Sheets(OhneMakros).Visible = xlSheetVeryHidden
End Sub
Private Sub Speichern()
Dim sh As Worksheet
Dim fehler As Boolean
Set sh = ActiveSheet
'geöffnetes Blatt merken:
With Sheets(OhneMakros)
.Unprotect Password:=pwWarnung
.Cells(Rows.Count, Columns.Count) = sh.Name
.Protect Password:=pwWarnung
End With
Application.EnableEvents = False
Application.ScreenUpdating = False
AllesAusblenden
On Error Resume Next
Me.Save
If Err.Number > 0 Then
MsgBox Err.Description, , "Fehler " & Err.Number
fehler = True
End If
On Error GoTo 0
AllesEinblenden
sh.Activate
Application.EnableEvents = True
Application.ScreenUpdating = True
If Not fehler Then Me.Saved = True
End Sub
Gruß Matthias