allgemeingültig Blattschutz aufheben
23.11.2007 08:26:13
Andreas
ich hab bei meiner Prozedur zum Ändern (siehe unten) ein Problem. Es gibt Dateien, wo ich Änderungen in den Verknüpfungen vornehmen muss, wo ein Blattschutz drüber liegt. Wie kann ich in die Prozedur einbauen, dass dieser Blattschutz entfernt / aufgehoben wird auch wenn ich bis jetzt noch gar nicht eingebaut habe, wie viele Tabellenblätter die unterschiedlichen Dateien haben, wo Veränderungen vorgenommen werden?
Es ist so, dass ich eine Vielzahl Dateien nach Verknüpfungen untersuchen muss und wenn ganz bestimmte Verknüpfungen vorkommen, müssen die geändert werden. Zum jetzigen Zeitpunkt ist das noch so, dass es aber einige Dateien (eben wahrscheinlich wegen des Blattschutzes) gibt, bei denen das Ändern nicht funktioniert. Viele Dinge sind ja in der Prozedur schon eingebaut, wie Nicht aktualisieren von Verknüpfungen beim Öffnen, Makros deaktivieren, Öffnen obwohl Schreibschutz, Es fehlt aber noch das Entfernen des Blattschutzes. Da müsste man doch die gesamten Blätter erst durchgehen, oder?
Und dann ist mir noch aufgefallen, dass ein paar wenige Dateien gar nicht geschlossen werden. Wieso kann ich mir nicht erklären. Das muss doch irgendein kleiner Fehler oder eine ungünstige Anweisung in der Prozedur sein, oder?
Kann mir bitte jemand mit dem Stück VBA helfen, um das allgemeingültig in die Prozedur einzubauen?
Gruss
Andreas
Hier noch die Prozedur:
Option Explicit
Dim z As Long
' Rekursive Prozedur
Public Sub xDirFile(xpath As String)
Dim xa As Long
Dim xDir As String
ReDim xt(0) As String
Dim xi As Long
Dim xAc As String
Dim wb As Workbook
Dim aLinks
Dim I As Integer
Dim newlink As String
' Zulassen von allen Formen von Dateien
' schreibgeschützte, versteckte, Systemdateien, Verzeichnisse, Ordner, ...
xDir = Dir(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
xa = 0
If Len(xDir) > 0 Then
xt(0) = xDir
End If
Do While Len(xDir) > 0
xDir = Dir
If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
xa& = xa& + 1
ReDim Preserve xt(xa)
xt(xa) = xDir
End If
Loop
On Error GoTo Schleife
For xi& = 0 To xa&
If Len(xt(xi)) = 0 Then
Exit For
ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
If Len(Dir$(xpath$ & "\" & xt$(xi&), vbNormal Or vbReadOnly Or vbHidden _
Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
'Aufgaben, die zu erledigen sind
'wenn Exceldatei
If UCase(Right(xt(xi), 3)) = "XLS" Then
'Debug.Print xpath & "\" & xt(xi)
' die "0" bedeutet, dass die Frage nach der Aktualisierung
' von Verlinkungen verneint wird
Set wb = Workbooks.Open(xpath & "\" & xt(xi), 0)
aLinks = wb.LinkSources(xlExcelLinks)
If Not IsEmpty(aLinks) Then
' Zählvariable -> kann weggelassen werden
z = z + 1
' diese Funktion steht im Modul "Referenzen"
NEUVERLINKEN aLinks, wb
End If
' Schreiben der Links in das Direktfenster
'Debug.Print xpath & "\" & xt(xi)
wb.Close savechanges:=False
Set wb = Nothing
End If
Else
Call xDirFile(xpath & "\" & xt(xi))
End If
End If
End If
Schleife:
Next xi&
On Error GoTo 0
End Sub