PDA

View Full Version : [SOLVED] Edit Excel Links in PPT Using VBA and Early Binding



Baiano42
07-28-2019, 11:51 AM
Greeting,

I've been trying to find a way to make my daily PPT report be more automated, and the biggest problem that I am crossing is getting the Excel Link to update to the most recent file location. I recently came across a article from Excel Off the Grid that noted that I could use early binding in Excel to link to the PPT instead of linking in PPT itself. The first part of the macro is designed to always know the last place my report was saved and get the current directory for it now.

Using the code below, it runs the macro, I get the following error code:
Run-time error '-2147467259 (80004005)':
Method 'SourceFullName' of object 'LinkFormat' failed

When I look at the linked object in the PPT, the link has not been changed. What needs to be changed here to make it replace the old link with the new one?



Sub EditPowerPointLinks()
'Set the link to the Object Library:
'Tools -> References -> Microsoft PowerPoint x.xx Object Library

Dim oldFilePath As String
Dim newFilePath As String
Dim sourceFileName As String
Dim pptApp As PowerPoint.Application
Dim pptPresentation As Object
Dim pptSlide As Object
Dim pptShape As Object


Application.CutCopyMode = False
Range("B5").Select
Selection.Copy
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A5").Select
Application.CutCopyMode = False
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D5").Select
Selection.Copy
Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'The file name and path of the file to update
sourceFileName = Range("E5").Value

'The old file path as a string (the text to be replaced)
oldFilePath = Range("C5").Value

'The new file path as a string (the text to replace with)
newFilePath = Range("B5").Value

'Set the variable to the PowerPoint Application
Set pptApp = New PowerPoint.Application

'Make the PowerPoint application visible
pptApp.Visible = True

'Set the variable to the PowerPoint Presentation
Set pptPresentation = pptApp.Presentations.Open(sourceFileName)

'Loop through each slide in the presentation
For Each pptSlide In pptPresentation.Slides

'Loop through each shape in each slide
For Each pptShape In pptSlide.Shapes

'Find out if the shape is a linked object or a linked picture
If pptShape.Type = msoLinkedPicture Or pptShape.Type _
= msoLinkedOLEObject Then

'Use Replace to change the oldFilePath to the newFilePath
pptShape.LinkFormat.SourceFullName = Replace(LCase _
(pptShape.LinkFormat.SourceFullName), LCase(oldFilePath), newFilePath)

End If
Next
Next

pptPresentation.UpdateLinks

'Release the memory
Set pptApp = Nothing
Set pptPresentation = Nothing
Set pptSlide = Nothing
Set pptShape = Nothing

End Sub

Baiano42
07-28-2019, 11:58 AM
A quick note: to get the E5 cell to display the current PPT location, I used the following:
In Cell H1:
=SUBSTITUTE(CELL("filename"),RIGHT(CELL("filename"),LEN(CELL("filename"))-FIND("@",SUBSTITUTE(CELL("filename"),"","@",LEN(CELL("filename"))-LEN(SUBSTITUTE(CELL("filename"),"",""))),1)),"*PPT*")
Went to Formulas->Define Name->(Name the new Defined Name without spaces), set the "Refers to:"
=FILES(Sheet1'!$H$1)
In Cell H2:
=INDEX(FileNameList,1)
In Cell H3:
=LEFT(CELL("filename"),FIND("[",CELL("filename"),1)-1)
In Cell H4:
=H3&H2

Baiano42
07-30-2019, 12:52 PM
Ok, after a *Lot* of trial and error, I was able to solve my own question, here is the final code I ended up with. (As I'm a complete novice at Excel VBA, there likely are ways to refine it further, but it works for me...)


'I wanted to make it run automatically every time, so I set it to run when I change the last variable in the excel portion of the report.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("I6")) Is Nothing Then

'to speed up the process of the macro

Application.ScreenUpdating = False


'Resets equation for Time to get either 0600 or 1800CST (In case one changes the cell, e.g. "1200 CST" for some reason
Range("H4").Value = "=IF('RNS Team'!F2=""PM"",""1800 CST"",""0600 CST"")"

'Update Report#: to current report # by counting the number of PDF's in the folder and adding 1
Dim FolderPath As String
Dim path As String
Dim count As Integer

FolderPath = Application.ActiveWorkbook.path
path = FolderPath & "\*.pdf"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range("H2").Value = count + 1

'Update Linked Object In PPT
Dim oldFilePath As String
Dim newFilePath As String
Dim sourceFileName As String 'This may be a source of error as I'm sourcing it from the value in cell E5
Dim pptApp As PowerPoint.Application
Dim pptPresentation As Object
Dim pptSlide As Object
Dim pptShape As Object


'This part is to identify the sourceFileName, oldFilePath, & newFilePath (see next section)
Application.CutCopyMode = False
Range("B5").Select
Selection.Copy
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A5").Select
Application.CutCopyMode = False
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D5").Select
Selection.Copy
Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If [B5] <> [C5] Then
Range("C5").Select
Application.CutCopyMode = False
Selection.Copy
Range("F5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
End If
'this changes the end of each cell I used the "Paste:=xlPasteValues" in to what links to PPT
Cells.Replace What:="[Daily Report Link.xlsm]Report", Replacement:= _
"Daily Report Link.xlsm!Report!R1C1:R8C10", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


ActiveWorkbook.Save

'The file name and path of the file to update
sourceFileName = Range("E5").Value

'The old file path
oldFilePath = Range("F5").Value

'The new file path
newFilePath = Range("B5").Value

'Set the variable to the PowerPoint Application
Set pptApp = New PowerPoint.Application

'Make the PowerPoint application visible
pptApp.Visible = True

'Set the variable to the PowerPoint Presentation
Set pptPresentation = pptApp.Presentations.Open(sourceFileName) 'sourcing to E5 value

'Loop through each slide in the presentation
For Each pptSlide In pptPresentation.Slides

'Loop through each shape in each slide
For Each pptShape In pptSlide.Shapes

'Find out if the shape is a linked object or a linked picture
If pptShape.Type = msoLinkedPicture Or pptShape.Type _
= msoLinkedOLEObject Then

'Use Replace to change the oldFilePath to the newFilePath
pptShape.LinkFormat.SourceFullName = Replace(LCase _
(pptShape.LinkFormat.SourceFullName), LCase(oldFilePath), newFilePath)

End If
Next
Next


'Release the memory
Set pptApp = Nothing
Set pptPresentation = Nothing
Set pptSlide = Nothing
Set pptShape = Nothing


Application.ScreenUpdating = True


End If
End Sub