Public Sub AutoExec()  ' Document_Open, Document_New, AutoOpen, AutoNew, etc.

    create_Addin_Menu

End Sub

Public Sub AutoClose()  ' Document_Open, Document_New, AutoOpen, AutoNew, etc.

    create_Addin_Menu

End Sub

Private Sub Document_Close()

    Delete_Addin_Menu

End Sub

Private Sub Document_Open()

    create_Addin_Menu

End Sub

Option Explicit

Option Compare Text

'*Installation Addin->Menubar

Const °AddinName As String = "Pfade_anpassen"

Sub Auto_Open()

    '----------------< Auto_Open() >----------------

    '--< Install_MenuBar >--

    Dim addin_Commandbar As CommandBar

    Set addin_Commandbar = find_Commandbar(°AddinName)

    '< check >

    If Not addin_Commandbar Is Nothing Then

        addin_Commandbar.Visible = True

        Exit Sub

    End If

    '</ check >

    On Error GoTo 0

    '--< Install_MenuBar >--

    '< create new >

    Set addin_Commandbar = CommandBars.Add(Name:=°AddinName, Position:=msoBarFloating, Temporary:=False)

    '</ create new >

    '----< Menue_Punkte_einfuegen >----

    Dim control_Element As CommandBarButton

    '------------< 1 >------------

    Set control_Element = addin_Commandbar.Controls.Add

    control_Element.Caption = "Pfade austauschen"

    control_Element.OnAction = "fx_Pfade_austauschen"

    control_Element.FaceId = 893

    control_Element.Style = msoButtonIconAndCaption

    control_Element.BeginGroup = True

    '------------</ 1 >------------

    '----</ Menue_Punkte_einfuegen >----

    '< anzeigen >

    addin_Commandbar.Visible = True

    '</ anzeigen >

    '----------------</ Auto_Open() >----------------

End Sub

Sub Auto_Close()

    '----------------< Uninstall in PowerPoint ??() >---------------

    '--< find_commandbar >--

    Dim addin_Commandbar As CommandBar

    Set addin_Commandbar = find_Commandbar(°AddinName)

    '< check >

    If Err.Number <> 0 Then Exit Sub

    If addin_Commandbar Is Nothing Then Exit Sub

    '</ check >

    '--</ find_commandbar >--

    addin_Commandbar.Delete

    '----------------</ Uninstall in PowerPoint ??() >---------------

End Sub

'=====================< Helper-Functions >==============

Public Function find_Commandbar(ByVal sName As String) As CommandBar

    '-----------< find_Commandbar() >--------------

    Dim search_Commandbar As CommandBar

    '----< @Loop: all_Commandbars >----

    For Each search_Commandbar In Application.CommandBars

        If search_Commandbar.Name = sName Then

            '< match_return >

            Set find_Commandbar = search_Commandbar

            Exit Function 'not necessary

            '</ match_return >

        End If

    Next

    '----</ @Loop: all_Commandbars >----

    '< nomatch >

    Set find_Commandbar = Nothing

    '</ nomatch >

    '-----------</ find_Commandbar() >--------------

End Function

'=====================</ Helper-Functions >==============

Option Explicit

'----< SETUP >----

Const °Pfad_Alt = "C:\Demo_Pfad_ALT"

Const °Pfad_Neu = "D:\NEUER_PFAD"

'----</ SETUP >----

Public Sub fx_Pfade_austauschen()

    '----------------< fx_Pfade_austauschen() >----------------

    '< get_Paths >

    '='C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\[Excel_mit_Wert_A_inC3.xlsx]Sheet1'!B$2

    Dim sPfad_Alt As String

    sPfad_Alt = °Pfad_Alt

    sPfad_Alt = LCase(sPfad_Alt)

    Dim sPfad_Neu As String

    sPfad_Neu = °Pfad_Neu

    sPfad_Neu = LCase(sPfad_Neu)

    '</ get_Paths >

    '< init >

    Dim objWord As Word.Document

    Set objWord = ActiveDocument

    '</ init >

    '--------< @Loop: Hyperlinks >--------

    '*loop all Hyperlinks

    Dim sAddress As String

    Dim link As Hyperlink

    For Each link In objWord.Hyperlinks

        '------< Hyperlink >------

         sAddress = link.Address

         sAddress = LCase(sAddress)

         If sAddress Like "*" & sPfad_Alt & "*" Then

             '< Link aendern >

             Dim sAddress_neu As String

             sAddress_neu = Replace(sAddress, sPfad_Alt, sPfad_Neu, 1, , vbTextCompare)

            link.Address = sAddress_neu

             '< Link aendern >

         End If

        '------</ Hyperlink >------

    Next

    '------</ @Loop: Hyperlink >------

    Dim objShape As Shape

    '------< @Loop: Shapes >------

    For Each objShape In objWord.Shapes

        '------< Shape >------

        If objShape.Type = msoLinkedOLEObject Then

            '----< IsLinkedOLEObject >----

            Dim sLink As String

            sLink = objShape.LinkFormat.SourceFullName

            sLink = LCase(sLink)

            If sLink Like "*" & sPfad_Alt & "*" Then

                '< Link aendern >

                Dim sLink_neu As String

                sLink_neu = Replace(sLink, sPfad_Alt, sPfad_Neu, 1, , vbTextCompare)

                objShape.LinkFormat.SourceFullName = sLink_neu

                '< Link aendern >

            End If

           '----</ IsLinkedOLEObject >----

        End If

        '------</ Shape >------

    Next

    '------</ @Loop: Shapes >------

    '------</ Change_Cells >------

    '< Abschluss >

    MsgBox "Fertig"

    '</ Abschluss >

    '----------------</ fx_Pfade_austauschen() >----------------

End Sub