Excel VBA to update OLE Linked files in PPT

  • Thread starter Thread starter killianbannon
  • Start date Start date
K

killianbannon

I have a macro which is meant to update any OLE links within PPT from
Excel (both 2000). The spreadsheet opens up a directory, looks for any
ppt or pps files and then opens them.
It searches for linked objects and if there are eny it then scans
through a column (containing current paths) in the spreadsheet to see
if it is there and if so it then replaces with the corresponding value
in column D.
Needless to say it doesn't work.
Any ideas?
(I have this working for links within Excel perfectly - its just PPT
that won't cooperate!)
My code is based on what appears to be the only way to do this -
http://www.rdpslides.com/pptfaq/FAQ00759.htm


Sub replaceExternalLinks(lookinPath)
Dim openedWorkBook As Workbook
Dim ws As Worksheet
Dim Cell As Object
Dim sheet_cell, rng As Range
Dim thisWB As String
Dim linkArray, vArrayItem, protectedSheetArray As Variant
Dim newValue, newFormula As Variant
Dim strFolderName, strFileName As String
Dim macroWorkbook, old_Folder, new_Folder As String
Dim totalDriveRows As Long
Dim loopRows As Long
Dim countMatchingLinks As Integer
Dim currentlyOpenWorkBooks As Integer
Dim oPPTApp As PowerPoint.Application
Dim oPPTPres As PowerPoint.Presentation
Dim oSld As Slide
Dim oSh As Shape
'Dim sPresentationFile As String
''''''''''''''''''''''''
'On Error Resume Next

Set oPPTApp = New PowerPoint.Application
oPPTApp.Visible = True

macroWorkbook = ActiveWorkbook.Name
Application.ScreenUpdating = False
totalDriveRows = ActiveWorkbook.Sheets("Mapping
Data").UsedRange.Rows.Count

'''''''''''''''''
'open the PPT/PPS
With Application.FileSearch
.NewSearch
.LookIn = "C:\someFolder"
.SearchSubFolders = False
.Filename = ".ppt;.pps"
If .Execute > 0 Then
Dim vaFileName As Variant
For Each vaFileName In .FoundFiles

If vaFileName <> lookinPath & "\" & macroWorkbook Then
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False

Set oPPTPres =
oPPTApp.Presentations.Open(vaFileName)
oPPTApp.WindowState = ppWindowMinimized
Dim sOldPath As String
Dim sNewPath As String
For Each oSld In
oPPTPres.Application.ActivePresentation.Slides 'oPPTPres.Slides
For Each oSh In
oPPTPres.Application.ActivePresentation.Slides.Shapes
' Change only linked OLE objects
If oSh.Type = msoLinkedOLEObject Then
For loopRows = 4 To totalDriveRows
'start looking @ row 4

Workbooks(macroWorkbook).Activate

ActiveWorkbook.Worksheets("Mapping Data").Activate
If
ActiveWorkbook.Worksheets("Mapping Data").Range("A" & loopRows).Value
<> "" And ActiveWorkbook.Worksheets("Mapping Data").Range("D" &
loopRows).Value <> "" And ActiveWorkbook.Worksheets("Mapping
Data").Range("A" & loopRows).Value <> "h" Then
sOldPath =
ActiveWorkbook.Sheets("Mapping Data").Range("A" & loopRows).Value
sNewPath =
ActiveWorkbook.Sheets("Mapping Data").Range("D" & loopRows).Value
On Error Resume Next
If
InStr(oSh.LinkFormat.SourceFullName, sOldPath, vbTextCompare) Then Exit
Sub
If
Len(Dir$(Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath))) >
0 Then
linkArray = linkArray &
"1" & vaFileName & "^," ' ActivePresentation.Path
linkArray = linkArray &
"2" & sOldPath & "^,"

oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName,
sOldPath, sNewPath)
linkArray = linkArray &
"3" & sNewPath & "^,"
oPPTPres.Save
End If
End If
Next ' looprows
End If
Next ' shape
Next ' slide

oPPTPres.Save
oPPTPres.Close
oPPTApp.Quit
Set oPPTPres = Nothing

Application.EnableEvents = True
Application.DisplayAlerts = True
End If
Next vaFileName
End If
End With
Application.ScreenUpdating = True
Set oPPTApp = Nothing

Workbooks(macroWorkbook).Worksheets("Links Log").Activate

Dim linkPart As Variant
Dim i, j As Integer
i = 0
If Right(linkArray, 2) = "^," Then linkArray = Left(linkArray,
Len(linkArray) - 2)
For Each linkPart In Split(linkArray, "^,")
ActiveCell.Value = linkPart
i = i + 1
If i = 3 Then
i = 0
ActiveCell.Offset(1, -2).Select
Else
ActiveCell.Offset(0, 1).Select
End If
ActiveCell = Selection
Next linkPart
Workbooks(macroWorkbook).Save

Application.ScreenUpdating = True
End Sub
 
Had to say without seeing your code. But my guess is that you are
trying to update the link from Excel and it would probably want to be
updated from PPT since PPT would be calling the OLE object.

Bran Reilly, MVP
 
I have a macro which is meant to update any OLE links within PPT from
Excel (both 2000). The spreadsheet opens up a directory, looks for any
ppt or pps files and then opens them.
It searches for linked objects and if there are eny it then scans
through a column (containing current paths) in the spreadsheet to see
if it is there and if so it then replaces with the corresponding value
in column D.
Needless to say it doesn't work.
Click to expand...

"doesn't work" doesn't work. It doesn't tell us much.

Where does the process fail? Do you get errors or does nothing at all happen?
 
MVP Brian Reilly said:
Had to say without seeing your code.
Click to expand...

Yo. Bri.

Somewhere on the right side of your keyboard there's probably a key that says
"Page Down"

View killianbannon's post again, then try pushing that key a time or three.

Neat, huh?

;-)
 
Im currently running it on a machine running Office 2003 and it is
making more progress.
If it finds a file with any external links it then scans through the
spreadsheet's column A and picks up the new link from column D.
What it should do is then try and update the link within PPT and copy
the PPT filename, old link path and new link path and store them in a
log.
It currently is not updating the link at all but of the ~900 links in
cols A & D, it copies each of these into the log for some reason.
It is as if it believes each of the possible links are valid and logs
them but doesn't actually update the link!
 
I managed to get it to update the link just now (typical) but have to
find out why it still logs the invalid links!
Thanks folks!
 
Im still having one problem with this and it revolves around two if
statements that are not working corrrectly:-

oSh = shape
sOldPath is a string representing the old path
sNewPath is a string representing a new path

<code>
If InStr(oSh.LinkFormat.SourceFullName, sOldPath, vbTextCompare) Then
If Len(Dir$(Replace(oSh.LinkFormat.SourceFullName, sOldPath,
sNewPath))) > 0 Then
do something #1
Else
do something else #1
End IF
Else
do something else #2
End if
</code>

However for some reason the two if statements are always true no matter
what sOldpath & sNewPath are. Trying to
Cstr(oSh.LinkFormat.SourceFullName) doesn't amke any difference.
Why does it always return true for these two If statements???
TIA
 
Im still having one problem with this and it revolves around two if
statements that are not working corrrectly:-
oSh = shape
sOldPath is a string representing the old path
sNewPath is a string representing a new path

<code>
If InStr(oSh.LinkFormat.SourceFullName, sOldPath, vbTextCompare) Then
Click to expand...

If you use a compare method (vbTextCompare) you aso have to supply a Start
argument:

InStr(1, oSh.LinkFormat.SourceFullName, sOldPath, vbTextCompare)

Normally this would have thrown an error. Do you have On Error Resume Next set
someplace earlier? Best to comment that out when debugging, at the very least,
since it masks all kinds of nasties.

And since InStr returns a variant (long) indicating the position of the first
match rather than a boolean T/F, this is less prone to misinterpretation:

If InStr(1, oSh.LinkFormat.SourceFullName, sOldPath, vbTextCompare) > 0 Then
' whatever

Then:
If Len(Dir$(Replace(oSh.LinkFormat.SourceFullName, sOldPath,
sNewPath))) > 0 Then
Click to expand...

This simply ensures that the file you're trying to relink to is in fact on the
path where you say it is. You can tell PPT to set the link to anything you
like. If the file's there, it'll work. If not, PPT will just ignore you. No
error messages or anything.
 
Back
Top