AW: Alter Hyperlink soll korrigiert werden
18.08.2020 21:49:41
Mullit
Hallo,
das ist so'n bißchen heikel, da ist Daniels Vorschlag schon zielführend, weil man nach der Aktion prüfen muß, ggf. nur mit Api und Office-Fenster-üperprüfung der Warnmeldung, aber Du kannst das mal versuchen, ging im Test eigentl. zuverlässig...
' **********************************************************************
' Modul: Tabelle1 Typ: Klassenmodul des Tabellenblattes
' **********************************************************************
Option Explicit
Private mobjHyperlink As Hyperlink
Private mobjTarget As Range
Private mblnRightClick As Boolean
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Hyperlinks.Count > 0 Then
Set mobjTarget = Target
mblnRightClick = True
End If
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Set mobjHyperlink = Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set mobjTarget = Target
Call Application.OnTime(EarliestTime:=Now, Procedure:="Check_Hyperlink")
End Sub
Friend Property Get Hyperlink() As Hyperlink
Set Hyperlink = mobjHyperlink
End Property
Friend Property Set Hyperlink(ByRef probjHyperlink As Hyperlink)
Set mobjHyperlink = probjHyperlink
End Property
Friend Property Get Target() As Range
Set Target = mobjTarget
End Property
Friend Property Get RightClick() As Boolean
Let RightClick = mblnRightClick
End Property
Friend Property Let RightClick(ByVal pvblnRightClick As Boolean)
Let mblnRightClick = pvblnRightClick
End Property
' **********************************************************************
' Modul: Modul1 Typ: Standardmodul
' **********************************************************************
Option Explicit
Option Private Module
Public Sub Check_Hyperlink()
Const TIMER_STEP As Single = 2! '// ggf. anpassen...
Const OLD_PATH As String = "Berichte\Datei.docx"
Const NEW_PATH As String = "Archiv\Berichte\Datei.docx"
Dim sngTimer As Single
With Tabelle1
If .Target.Hyperlinks.Count > 0 Then
sngTimer = Timer
Do Until Timer - sngTimer > TIMER_STEP Or Not .Hyperlink Is Nothing Or .RightClick
DoEvents
Loop
If .Hyperlink Is Nothing And Not .RightClick Then
Call MsgBox(Prompt:="File not found, path will be adjusted...", _
Buttons:=vbExclamation, Title:="Pathfinder")
With .Target.Hyperlinks(1)
.Address = Replace$(Expression:=.Address, Find:=OLD_PATH, Replace:=NEW_PATH)
End With
'///// Call .Target.Hyperlinks(1).Follow(NewWindow:=True) '///// bei Bedarf nach Korr. gleich öffnen...
ElseIf .RightClick Then
.RightClick = False
Else
'// "file exits"
Set .Hyperlink = Nothing
End If
Call .Target.Offset(0, -1).Select '// ggf. anpassen...
End If
End With
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 12
Gruß, Mullit