Hyperlinks korrigieren

Hallo liebes Forum,
für manchen sicher ein einfaches Problem...für mich leider nicht:
Wahrscheinlich durch ein MS-Update wurden sämtliche Links in einer Excel-Datei mit
C:\Users\BENUTZER\AppData\Roaming\Microsoft\Excel\... überschrieben. Ich möchte sie per VB-Script ändern. Es handelt sich um Links zu PDF-Dateien, die im gleichen Ordner liegen. Früher war der Netzwerkpfad vorangestellt, aber wenn die Dateien im gleichen Ordner liegen, benötigt man den Pfad nicht(ist auch günstiger, wenn der Ordner woanders hin kopiert wird). Im Script müßte noch getestet werden, ob der Hyperlink mit C:\Users\BENUTZER... beginnt, da einige Links schon manuell geändert wurden.
Ich hoffe, es hat jemand eine Lösung und es wird nicht zu kompliziert für mich.
Danke.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
kannst mal diesen Code testen.

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 Makro1()
Dim HypLink As Hyperlink
Dim PathFrom As String, PathTo As String
PathFrom = ThisWorkbook.Path
'Tabelle evtl. anpassen
For Each HypLink In Tabelle1.Hyperlinks
PathTo = HypLink.Address
PathTo = GetRelativePath(PathFrom, PathTo)
If PathTo  Hyp.Address Then
HypLink.Address = PathTo
End If
Next
End Sub

Gruß Tino

Sub HyperRename() Dim Pfad As String, Finden As String, TMPA As String, TMPT As String, HPL Pfad = ThisWorkbook.Path & "\" Finden = "C:\Users\BENUTZER\AppData\Roaming\Microsoft\Excel\" For Each HPL In Sheets("Tabelle1").Hyperlinks TMPA = Replace(HPL.Address, Finden, Pfad) TMPT = Replace(HPL.TextToDisplay, Finden, Pfad) HPL.Address = Replace(TMPA, " ", "%20") HPL.TextToDisplay = TMPT Next End Sub

Sub HyperRename() Dim Pfad As String, Finden As String, TMPA As String, TMPT As String, HPL Dim WS_Count As Integer, Z As Integer, I As Integer Pfad = ThisWorkbook.Path & "\" Finden = "C:\Users\BENUTZER\AppData\Roaming\Microsoft\Excel\" WS_Count = ActiveWorkbook.Worksheets.Count Z = 0 For I = 1 To WS_Count For Each HPL In Sheets(I).Hyperlinks Z = Z + 1 TMPA = Replace(HPL.Address, Finden, Pfad) TMPT = Replace(HPL.TextToDisplay, Finden, Pfad) HPL.Address = Replace(TMPA, " ", "%20") HPL.TextToDisplay = TMPT Next HPL Next I MsgBox ("Anzahl Korrekturen: " & Z) End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread