Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

PowerPoint, vba: alle Pfade in Grafiken und Links ändern

22.02.2019 (👁469)

PowerPoint, vba: alle Pfade in Grafiken und Links ändern

Aufgabe:

Das folgende Makro ändert alle pfade in einer Microsoft PowerPoint Datei zu einem neuen Laufwerk oder Verzeichnis

Die Datei ist als pptm mit Makro und als Addin für Powerpoint zum Datei-Download im Anhang.

Powerpoint Addin

Als Addin für die globale Verwendung

Installation des Powerpoint Addin

Vba Macro Code

Beigefügter Macro Code in vba Microsoft powerPoint

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 objPPT As Presentation

    Set objPPT = ActivePresentation

    '</ init >

   

   

    '--------< @Loop:Slides >--------

    '*Loop all Slides and Shapes and when Type LinkedOLE then change SourcefullName

    Dim objSlide As Slide

    Dim objShape As Shape

    For Each objSlide In objPPT.Slides

        '------< Slide >------

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

        For Each objShape In objSlide.Shapes

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

            DoEvents    '*

           

            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 >------

        '------</ Slide >------

    Next

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

   

 

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

    '*loop all Hyperlinks

    Dim sAddress As String

   

    For Each objSlide In objPPT.Slides

        '------< Slide >------

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

        Dim link As Hyperlink

        For Each link In objSlide.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 >------

        '------</ Slide >------

    Next

    '--------</ @Loop:Slides.Hyperlinks >--------

 

 

   

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

   

    '< Abschluss >

    On Error GoTo 0

    MsgBox "Fertig"

    '</ Abschluss >

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

End Sub

PowerPoint Addin Code

Dieser Vba Macro Code installiert in Powerpoint ein Makro.

Beim Installieren wird die Commandbar eingefügt. Beim Entfernen des Makro wird die Commandbar wieder entfertn

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 >==============