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
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
Dim wksSchutz() As Boolean, wks As Worksheet, iJ As Integer
' 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)
'Blattshutzmerken und aufheben
ReDim wksSchutz(1 To wb.Worksheets.Count)
For iJ = 1 To wb.Worksheets.Count
Set wks = wb.Worksheets(iJ)
wksSchutz(iJ) = wks.ProtectContents
If wks.ProtectContents = True Then
wks.Unprotect
End If
Next
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)
'Blattshutz wieder setzen
For iJ = 1 To wb.Worksheets.Count
Set wks = wb.Worksheets(iJ)
If wksSchutz(iJ) = True Then
wks.Protect
wks.Protect contents:=True
End If
Next
wb.Save '? soll das geänderte Workbook nicht gespeichert werden?
wb.Close savechanges:=False
Set wb = Nothing
Set wks = Nothing
ReDim wksshutz(1 To 1)
End If
Else
Call xDirFile(xpath & "\" & xt(xi))
End If
End If
End If
Schleife:
'Datei nach Fehler schließen
If Not wb Is Nothing Then
MsgBox "Bei Datei " & wb.FullName & " ist ein Fehler aufgetreten" & vbLf & _
"Datei wird ohne speichern geschlossen!!"
wb.Close savechanges:=False
End If
Next xi&
On Error GoTo 0
End Sub