Hallo,
Hoffnung gibt es doch immer - oder sie stirbt wenigstens zuletzt ;-)
Dein Verfahren scheint mir ziemlich umständlich und fehleranfällig zu
sein, wie du auch schon selbst erkannt hast. Ich würde dir folgende
Vorgehensweise vorschlagen: Füge deiner Arbeitsmappe eine Tabelle
hinzu, benenne sie in Data um und schreibe in Spalte A alle in Frage
kommenden Festplatten-Seriennummern. Erstelle nun in DieseArbeitsmappe
folgenden Code:
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim strMsg As String
If ThisWorkbook.Saved = False Then
strMsg = "Sollen Ihre Änderungen in '" _
& ThisWorkbook.Name & "' gespeichert werden?"
Select Case MsgBox(strMsg, vbYesNoCancel + vbQuestion)
Case vbYes
SpecialSave 1
Case vbNo
ThisWorkbook.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
SpecialSave 0
End Sub
Private Sub Workbook_Open()
Dim wksA As Worksheet, rngA As Range, rngB As Range, _
lngLastRow As Long, strMsg As String
With ThisWorkbook.Worksheets("Data")
lngLastRow = .Cells(65536, 1).End(xlUp).Row
Set rngA = .Range(.Cells(1, 1), .Cells(lngLastRow, 1))
End With
Set rngB = rngA.Find(What:=GetHDNr(strDrive), LookAt:=xlWhole)
If rngB Is Nothing Then
strMsg = "Sie sind nicht berechtigt, diese Datei zu öffnen!"
MsgBox strMsg, vbOKOnly + vbCritical, "Datei öffnen"
If Application.Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close Savechanges:=False
End If
Else
UnhideSheets 0
End If
End Sub
Und in Modul1 kommt folgender Code:
Option Explicit
Public Const strDrive As String = "C"
Public Function GetHDNr(strDrive As String) As Variant
Dim Fso As Object, Drv As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.DriveExists(strDrive) Then
Set Drv = Fso.GetDrive(strDrive)
GetHDNr = Drv.SerialNumber
End If
Set Drv = Nothing
Set Fso = Nothing
End Function
Public Sub HideSheets(Dummy As Integer)
Dim wksA As Worksheet
ThisWorkbook.Worksheets("Cover").Visible = xlSheetVisible
For Each wksA In ThisWorkbook.Worksheets
If LCase$(wksA.Name) <> "cover" Then
wksA.Visible = xlSheetVeryHidden
End If
Next wksA
ThisWorkbook.Saved = True
End Sub
Public Function SheetExists( _
ByVal strSheetName As String) As Boolean
Dim wksA As Worksheet
For Each wksA In ThisWorkbook.Worksheets
If LCase$(wksA.Name) = LCase$(strSheetName) Then
SheetExists = True
Exit For
End If
Next wksA
End Function
Public Sub UnhideSheets(Dummy As Integer)
Dim wksA As Worksheet
For Each wksA In ThisWorkbook.Worksheets
If LCase$(wksA.Name) <> "cover" And _
LCase$(wksA.Name) <> "data" Then
wksA.Visible = xlSheetVisible
End If
Next wksA
With ThisWorkbook
.Worksheets("Cover").Visible = xlSheetVeryHidden
.Worksheets("Data").Visible = xlSheetVeryHidden
.Saved = True
End With
End Sub
Public Sub SpecialSave(Dummy As Integer)
Dim wksA As Worksheet
If SheetExists("Cover") = False Then
Set wksA = ThisWorkbook.Worksheets.Add
wksA.Name = "Cover"
wksA.Protect GetHDNr(strDrive)
End If
HideSheets 0
Application.EnableEvents = False
ThisWorkbook.Save
Application.EnableEvents = True
If Dummy = 0 Then
UnhideSheets 0
End If
End Sub
Das ist zwar auf den ersten Blick auch recht aufwändig, hat
aber gegenüber deiner Version den Vorteil, dass du den Code
ja nur einmal eingeben musst, und danach läuft alles völlig
transparant und ohne Zutun sowohl des Benutzers als auch
von deiner Seite ab.
Die Wirkungsweise ist folgende: Beim Öffnen der Arbeitsmappe
wird die Seriennummer der Festplatte gelesen. Wird sie in der
Liste der gültigen Nummern gefunden, werden die verborgenen
Tabellen ein- und die nicht benötigten "Hilfstabellen"
ausgeblendet. Dabei wird deren Visible-Eigenschaft auf den
Wert xlSheetVeryHidden gesetzt, wodurch verhindert wird, dass
der Benutzer sie im Menü Format - Blatt - Einblenden sichtbar
machen kann. Beim Öffnen auf einem anderen Rechner erhält
der Benutzer den Hinweis, dass er dazu nicht berechtigt ist,
und die Mappe wird wieder geschlossen. Werden beim Öffnen
die Makros aktiviert, sieht der Benutzer nur ein leeres und
schreibgeschütztes Deckblatt.
Damit das funktioniert, wird vor dem Speichern zunächst,
sofern es noch nicht existiert, dieses leere Blatt namens
"Cover" eingefügt und dann alle Blätter bis auf dieses
auf xlSheetVeryHidden gesetzt. Damit der Benutzer danach
ggf. weiterarbeiten kann, werden dann alle für ihn
relevanten Blätter wieder eingeblendet.
Folgendes musst du noch beachten: Wird die Datei auf einem
anderen als Laufwerk C installiert, musst du in Modul1 in der
Zeile
Public Const strDrive As String = "C"
C durch den entsprechenden Laufwerkbuchstaben ersetzen.
Außerdem solltest du das VBA-Projekt gegen Einsichtnahme
schützen, sonst kann ein versierter Benutzer die Blätter
in der IDE sichtbar machen. Öffne dazu in der VBA-IDE im
Menü Extras die VBA-Projekteigenschaften, setze auf der
Registerkarte Schutz bei "Projekt für die Anzeige sperren"
ein Häkchen und gib unten ein Passwort ein, das nur dir
bekannt ist. Nach dem Speichern wird beim Versuch, das
Projekt zu öffnen, das Passwort abgefragt.
Um nachträglich weitere Festplattennummern einzugeben
oder nicht mehr aktuelle zu löschen, musst du das VBA-
Projekt öffnen. Wähle oben links im Projektexplorer das
Blatt Data aus, und sofern darunter nicht dessen
Eigenschaften angezeigt werden, drücke F4 oder wähle im
Menü Ansicht - Eigenschaftsfenster. Dort klickst du in
das Feld Visible und änderst daneben im DropDown-Feld die
Eigenschaft von xlSheetVeryHidden auf xlSheetVisible.
Danach kannst du das Blatt Data auswählen und die Änderungen
vornehmen. Beim Speichern (Makros müssen aktiviert sein)
wird es automatisch wieder verborgen.
Sorry, ist ein bisschen viel, aber es erfüllt seinen Zweck.
Ich hoffe, dass ich in der Eile nichts übersehen habe,
sonst melde dich noch mal.
Gruß
|