Gruppe
Extern
Problem
Aus dem Hyperlink in Zelle A1 soll die absolute Adresse ermittelt werden. WindowsScriptingHost muss installiert sein.
StandardModule: Modul1
Sub GetFileName()
Dim fs As Object
Dim f As Object
Dim iChar As Integer
Dim sFolder As String, sOrdner As String, sFile As String
Dim sPathR As String, sPathA As String
sPathR = ThisWorkbook.Path
sFolder = Range("A1").Hyperlinks(1).Address
If InStr(sFolder, "..\") Then
For iChar = Len(sFolder) To 1 Step -1
If Mid(sFolder, iChar, 1) = "\" Then Exit For
Next iChar
sFile = Right(sFolder, Len(sFolder) - iChar)
sOrdner = WorksheetFunction.Substitute(sFolder, "..\", "")
sOrdner = Left(sOrdner, InStr(sOrdner, "\"))
Set fs = CreateObject("Scripting.FileSystemObject")
Do While InStr(sFolder, "..\")
Set f = fs.GetFolder(sPathR)
sPathR = WorksheetFunction.Substitute(sPathR, "\" & f.Name, "", 1)
sFolder = WorksheetFunction.Substitute(sFolder, "..\", "", 1)
Loop
Set fs = Nothing
Set f = Nothing
sFile = sPathR & "\" & sOrdner & sFile
Else
sFile = ThisWorkbook.Path & "\" & sFile
End If
MsgBox sFile
End Sub