Есть дополнительное готовое решение для замены связи в Pptm, запускаете макрос, выдает диалоговое окно со связью, которую будете менять, далее попросить выбрать файл, на который вы произведете замену и так для всех связей в презентации. Работает при условии, что все связи возможно заменить из указанных файлов, а также, желательно переименовать новые файлы, на которые будет ссылаться презентация.
P.S.: Если кто-то знает, как ускорить работу этого кода (работает на 200 слайдах) или как избежать ошибки при связях на не существующие книги, буду благодарен!
| Код |
|---|
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Sub changeLinkTargets()
Application.DisplayAlerts = False
Dim pptSlide As Slide
Dim pptShape As Shape
Dim oldlinks(10) As String
Dim newlinks(10) As String
Dim temp As String
Dim counter As Integer
counter = 0
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoLinkedOLEObject Or pptShape.Type = msoLinkedPicture Then
With pptShape.LinkFormat
temp = Left(.SourceFullName, InStr(.SourceFullName, "!") - 1)
If Not IsInArray(temp, oldlinks) Then
oldlinks(counter) = temp
counter = counter + 1
End If
End With
End If
'DoEvents
Next pptShape
'DoEvents
Next pptSlide
Dim fd As FileDialog
Dim fullpath As String
Dim fileselected As Variant
Set fd = Application.FileDialog(msoFileDialogOpen)
For i = 0 To counter - 1
MsgBox (oldlinks(i))
With fd
.AllowMultiSelect = False
.Show
newlinks(i) = .SelectedItems.Item(1)
End With
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoLinkedOLEObject Or pptShape.Type = msoLinkedPicture Then
With pptShape.LinkFormat
If InStr(1, UCase(.SourceFullName), UCase(oldlinks(i))) Then
.SourceFullName = Replace(.SourceFullName, oldlinks(i), newlinks(i))
End If
End With
End If
'DoEvents
Next pptShape
'DoEvents
Next pptSlide
Next i
MsgBox ("Ура, сработало!")
End Sub
'Эта часть кода обновляет данные на слайдах после замены связей
Sub UpdateLinkTargets()
Dim pptSlide As Slide
Dim pptShape As Shape
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoLinkedOLEObject Or pptShape.Type = msoLinkedPicture Then
With pptShape.LinkFormat
.Update
End With
End If
'DoEvents
Next pptShape
'DoEvents
Next pptSlide
MsgBox ("Ура, сработало!")
End Sub
|
делаю модель оценки и вяжу отчеты в презентацию. но при отправке файла заказчику, меняется путь. как макросом заменить все пути для всех отчетов?