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