Readdy Write

PowerPoint: Automatisch verlinkte Graphiken ändern per vba Code

08.12.2018 (👁8179)

PowerPoint: Automatisch verlinkte Graphiken ändern

 

Betrifft: PowerPoint, Excel vba

 

Vba Code:

Alle verlinkte Grafiken in PowerPoint zu einer andern Excel-Mappe verschieben

 

 

Dieses Makro unter Microsoft MS PowerPoint ändert alle bisher verlinkten Bereiche zu einer Excel Datei unter PowerPoint zu einer anderen Excel Arbeitsmappe.

Option Explicit On

 

 

Public Sub Verknuepfung_Linked_Shapes_zu_Excel_aendern()

    '--------------------< Verknuepfung_Linked_Shapes_zu_Excel_aendern() >---------------- 

    '*mit diesem Makro werden alle verlinkten Graphiken zu Excel-Dokumenten zu einem neuen Pfad erneuert 

    '< setup > 

    Dim sPfad As String

    sPfad = "C:\Users\poppr\Desktop\Analysedatei_FB_KER19.xlsm"

    '</ setup > 

 

    '< meldung > 

    If vbYes <> MsgBox("Das Anbinden kann länger dauern.. " & vbCrLf & "Das Makro oeffnet gleich die ZielExcel-Datei und bindet die Folien an." & vbCrLf & "Soll gestartet werden ..", vbYesNo, "Soll die Anbindung gestartet werden?"Then

        Exit Sub

    End If

    '</ meldung > 

 

    '< Excel_oeffnen > 

    '*erst Excel Ziel oeffnen 

    Dim objExcel As Excel.Application

    Set objExcel = New Excel.Application 

    objExcel.Workbooks.Open sPfad 

    '</ Excel_oeffnen > 

 

    '< init > 

    Dim objPPT As Presentation

    Set objPPT = ActivePresentation 

    '</ init > 

    

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

    Dim objSlide As Slide

    For Each objSlide In objPPT.Slides

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

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

        Dim objShape As Shape

        For Each objShape In objSlide.Shapes

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

            DoEvents    '* 

 

            If objShape.Type = msoLinkedOLEObject Then

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

                '< set_Link_manual > 

                '*zur Sicherheit Link auf Manuell schalten 

                'manuelle Verknuepfung 

                If Not objShape.LinkFormat.AutoUpdate = ppUpdateOptionManual Then

                    objShape.LinkFormat.AutoUpdate = ppUpdateOptionManual

                End If

                '</ set_Link_manual > 

 

                '----< Check_Link_IsExcel >---- 

                '*wie: Excel.SheetMacroEnabled.12 

                If InStr(objShape.OLEFormat.ProgID, "Excel.Sheet") > 0 Then

                    '--< Link_IsExcel >-- 

                    Dim sLink As String

                    sLink = objShape.LinkFormat.SourceFullName

                    '*Link ist wie:   C:\.....xxx.xlsm!ExcelBlatt!Z1S1:Z1:S1 

 

                    If InStr(1, sLink, sPfad, vbTextCompare) < 1 Then

                        '----< Link_ist_falsch >---- 

 

                        '< get pos_Excel > 

                        Dim pos_Excel As Integer

                        pos_Excel = InStrRev(sLink, ".xls", -1, vbTextCompare)

                        '</ get pos_Excel > 

 

                        If pos_Excel > 0 Then

                            '< get_pos_Area > 

                            Dim posArea As Integer

                            posArea = InStr(pos_Excel, sLink, "!", vbBinaryCompare)

                            '<( get_pos_Area > 

 

                            '< get neuer Pfad > 

                            Dim sArea As String

                            sArea = Mid(sLink, posArea)

 

                            Dim sLink_Neu As String

                            sLink_Neu = sPfad & sArea

                            '</ get neuer Pfad > 

 

                            '< Link aendern > 

                            objShape.LinkFormat.SourceFullName = sLink_Neu

                            '< Link aendern > 

                        End If

                        '----</ Link_ist_falsch >---- 

                    End If

                    '--</ Link_IsExcel >-- 

                End If

                '----</ Check_Link_IsExcel >---- 

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

            End If

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

        Next

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

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

    Next

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

 

    '< Abschluss > 

    objExcel.Quit

    '</ Abschluss > 

 

    MsgBox("Fertig!")

    '--------------------</ Verknuepfung_Linked_Shapes_zu_Excel_aendern() >---------------- 

End Sub

 

 

 

Dabei wird Excel als verlinkte Grafik eingebunden..

 

Wie bindet man in Excel einen Excel-Bereich als verlinkte Graphik ein?

 

Eine verlinkte Grafik hat zur Folge, dass sich die Grafik ändert, sobald der Bereich sich in der original-Excel Tabelle geändert hat und man auf Verlinkung aktivieren ausführt.

Einen Excel Bereich markieren

Auf PowerPoint wechseln und

Und dann->auf Menü->START->Einfügen ->Erweitert->Inhalte einfügen->VERLINKUNG einfügen->

Als Microsoft Excel-Arbeitsmappe-objekt  (aber als verlinkte Grafik !!)


0,00 €