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