Я закончил тем, что написал решение проблемы, для которой мне было трудно найти ответ, поэтому я хотел поделиться тем, что в итоге помогло мне.
Код просматривает рабочий каталог Word-документа, находит первый Excel-документ (у меня только 1 файл Excel на папку в моей работе, поэтому эта настройка работает для меня) и изменяет источник всех объектов OLE в документ word, соответствующий документу Excel, что позволяет создавать пару шаблонов word / excel и перемещать их в разные места.
* ПРИМЕЧАНИЕ. Я использовал специальные объекты / функции Windows для ввода-вывода, т.е. MyFile, MyFSO, MyFolder ... и т. Д., Но я не думаю, что было бы ужасно сложно создать платформу ввода-вывода агностик.
** ПРИМЕЧАНИЕ: Я также на самом деле не добавил никакой проверки ошибок, поскольку это быстрый и грязный макрос, который используется внутри для облегчения переносимости. Я никогда раньше не использовал vba, поэтому очистка от мусора и т. Д. Была просто броском там, если есть способ реорганизовать все и очистить это, пожалуйста, дайте мне знать.
Sub UpdateWordLinks()
Dim newFilePath As Variant
Dim excelDocs As Variant
Dim range As Word.range
Dim shape As shape
Dim section As Word.section
excelDocs = GetFileNamesbyExt(ThisDocument.Path, ".xlsx")
'The new file path as a string (the text to replace with)'
newFilePath = ThisDocument.Path & Application.PathSeparator & excelDocs(1)
Call updateFields(ThisDocument.fields, newFilePath)
For Each section In ThisDocument.Sections
Call updateHeaderFooterLinks(section.headers, newFilePath)
Call updateHeaderFooterLinks(section.Footers, newFilePath)
Next
'Update the links
ThisDocument.fields.Update
Set newFilePath = Nothing
Set excelDocs(1) = Nothing
Set excelDocs = Nothing
Set range = Nothing
Set shape = Nothing
Set section = Nothing
End Sub
Function GetFileNamesbyExt(ByVal FolderPath As String, FileExt As String) As Variant
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim MyFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = MyFolder.Files
ReDim Result(1 To MyFiles.count)
i = 1
For Each MyFile In MyFiles
If InStr(1, MyFile.Name, FileExt) <> 0 Then
Result(i) = MyFile.Name
i = i + 1
End If
Next MyFile
ReDim Preserve Result(1 To i - 1)
GetFileNamesbyExt = Result
Set MyFile = Nothing
Set MyFSO = Nothing
Set MyFolder = Nothing
Set MyFiles = Nothing
End Function
Function updateHeaderFooterLinks(headersFooters As headersFooters, newFilePath As Variant)
Dim headerFooter As Word.headerFooter
For Each headerFooter In headersFooters
Call updateFields(headerFooter.range.fields, newFilePath)
Next
Set headerFooter = Nothing
End Function
Function updateFields(fields As fields, newFilePath As Variant)
Dim field As field
Dim oldFilePath As Variant
For Each field In fields
If field.Type = wdFieldLink Then
oldFilePath = field.LinkFormat.SourceFullName
field.Code.Text = Replace(field.Code.Text, _
Replace(oldFilePath, "\", "\\"), _
Replace(newFilePath, "\", "\\"))
End If
Next
Set field = Nothing
Set oldFilePath = Nothing
End Function
Это работает для меня, позволяя мне скопировать и вставить файл Word и Excel вместе в новое место и запустить макрос, или разрешив мне скопировать и вставить только документ Word и запустить макрос, чтобы связать его с Excel документ в новом месте.
** Я должен также отметить, что мне нужно было только посмотреть в теле и заголовках / нижних колонтитулах ссылки, которые мы используем, так что этот код не так надежен, как мог бы, но я не думаю, что это будет слишком трудно добавить еще одну или две петли, чтобы скрыть пропущенные истории
Ура!