Option Explicit
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32" (lpbi As InfoT) As Long
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Public Sub Dateiliste()
Dim strLinks
Dim index As Long
Dim i As Integer
Dim strDatei As String
Dim strAltPfad As String
Dim strNeuPfad As String
Dim intZeile As Integer
strAltPfad = Range("B1").Value
strNeuPfad = Range("B2").Value
intZeile = 5
Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = GetAOrdner
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = True
If .Execute > 0 Then
Application.EnableEvents = False
For index = 1 To .FoundFiles.Count
strDatei = .FoundFiles(index)
intZeile = intZeile + 1
Cells(intZeile, 1) = strDatei
Workbooks.Open (strDatei), UpdateLinks:=False
strLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(strLinks) Then
For i = LBound(strLinks) To UBound(strLinks)
If UCase(Left(strLinks(i), Len(strAltPfad))) = UCase(strAltPfad) Then
ActiveWorkbook.ChangeLink Name:=strLinks(i), _
NewName:=strNeuPfad & Right(strLinks(i), Len(strLinks(i)) - Len(strAltPfad)), _
Type:=xlExcelLinks
ThisWorkbook.Sheets(1).Cells(intZeile, 2) = "alte Verknüpfung: " & strLinks(i)
intZeile = intZeile + 1
ThisWorkbook.Sheets(1).Cells(intZeile, 2) = "neue Verknüpfung: " & strNeuPfad & Right(strLinks(i), Len(strLinks(i)) - Len(strAltPfad))
ActiveWorkbook.Save
End If
Next i
End If
ActiveWorkbook.Close savechanges:=False
Next
End If
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Function GetAOrdner() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim(FolderName)
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
GetAOrdner = FolderName
End Function