Relativer Hyperlink mit VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'Benötigte Konstanten Private Const MAX_PATH = 260 Private Const FILE_ATTRIBUTE_DIRECTORY = &H10 Private Const FILE_ATTRIBUTE_NORMAL = &H80 'API-Funktion deklarieren Private Declare Function apiPathRelativePathTo Lib "shlwapi.dll" _ Alias "PathRelativePathToA" (ByVal pszPath As String, _ ByVal pszFrom As String, ByVal dwAttrFrom As Long, _ ByVal pszTo As String, ByVal dwAttrTo As Long) As Long Public Function GetRelativePath(PathFrom As String, PathTo As String) As String Dim pszPath As String pszPath = Space(MAX_PATH) 'API-Funktion aufrufen apiPathRelativePathTo pszPath, PathFrom, _ FILE_ATTRIBUTE_DIRECTORY, PathTo, FILE_ATTRIBUTE_NORMAL 'Rückgabe des relativierten Pfads GetRelativePath = Left$(pszPath, InStr(pszPath, Chr(0)) - 1) End Function Sub Test() Dim sPathGrund As String Dim DateiName As String Dim sPath As String Dim sHyperlink As String sPath = ThisWorkbook.Path DateiName = Application.GetOpenFilename sHyperlink = GetRelativePath(sPath, DateiName) ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=sHyperlink, ScreenTip:="Gehe zu Verwenderhinweis" End Sub

Hallo,
habe mal etwas getestet, GetRelativePath bleibt leer,
wenn der Pfad nicht gekürzt werden kann.
Müssen wir noch etwas einbauen, jetzt sollte es funzen.


Option Explicit
'Benötigte Konstanten
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_NORMAL = &H80
'API-Funktion deklarieren
Private Declare Function apiPathRelativePathTo Lib "shlwapi.dll" _
Alias "PathRelativePathToA" (ByVal pszPath As String, _
ByVal pszFrom As String, ByVal dwAttrFrom As Long, _
ByVal pszTo As String, ByVal dwAttrTo As Long) As Long
Public Function GetRelativePath(PathFrom As String, PathTo As String) As String
Dim pszPath As String
pszPath = Space(MAX_PATH)
'API-Funktion aufrufen
apiPathRelativePathTo pszPath, PathFrom, _
FILE_ATTRIBUTE_DIRECTORY, PathTo, FILE_ATTRIBUTE_NORMAL
'Rückgabe des relativierten Pfads
GetRelativePath = Left$(pszPath, InStr(pszPath, Chr(0)) - 1)
If GetRelativePath = "" Then GetRelativePath = PathTo
End Function
Sub Test()
Dim sPathGrund As String
Dim DateiName As String
Dim sPath As String
Dim sHyperlink As String
sPath = ThisWorkbook.Path
DateiName = Application.GetOpenFilename
sHyperlink = GetRelativePath(sPath, DateiName)
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=sHyperlink, ScreenTip:="Gehe zu  _
Verwenderhinweis"
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Relativer Hyperlink mit VBA

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread