Здравствуйте стоит такая задача. Необходимо связать файл WORD с EXEL, с определенным файлом для подтягивания диаграмм. Но чтобы была возможность поменять файл EXEL и данные в WORDавтоматически подтянулись. Например есть файл "док 1" (в приложении) там есть диаграмма она автоматически связана с файлом "Книга 5". Нужно сделать так чтобы можно было автоматически подтянуть данные, например выбрал файл "Книгу 2", диаграмма в "Док 1" должна автоматически обновится. Помогите очень нужно Также важно чтобы в диаграммах не менялся исходный формат диаграмм, то есть они не становились больше или меньше, уже или шире.. Нашел на просторах вот такой макрос:
Sub Смена_источника_данных() ' ' Смена_источника_данных Макрос ' Dim oFld As Field 'Поле Dim OldFileName As String 'Старое имя файла Dim NewFileName As String 'Новое имя файла Dim FieldCode As String 'Код поля Dim ReplaceAllPath As Boolean 'Заменять весь путь к файлу или только имя Dim StartPath As Integer, EndPath As Integer 'Начало и конец пути к файлу в коде поля Dim FullPath As String Dim Name As String
For Each oFld In ActiveDocument.Fields If oFld.Type = wdFieldLink Then 'Если поле является полем ссылки If InStr(oFld.Code.Text, "Excel.SheetMacroEnabled.12") <> 0 Then 'Если поле ссылается на лист Excel FullPath = oFld.Code.Text Exit For End If End If Next
'Отделение имени файла от мусора i = InStrRev(FullPath, "\\") 'позиция последнего \\ Name = Mid(FullPath, i + 2) j = InStrRev(Name, Chr(34)) 'позиция конца имени файла с расширением OldFileName = Left(Name, j - 1)
'Ввод старого имени файла OldFileName = InputBox("Укажите старое имя файла с расширением в ссылке, которое нужно изменить", "Изменение ссылок", OldFileName) If Len(OldFileName) = 0 Then Exit Sub
'Выбор нового файла With Application.FileDialog(msoFileDialogFilePicker) .Title = "Выберите новый файл, с которым должен быть связан документ" .AllowMultiSelect = False .ButtonName = "Выбрать" .Filters.Clear .Filters.Add "Таблицы Excel", "*.xls; *.xlsx; *.xlsm" If .Show Then NewFileName = .SelectedItems(1) Else Exit Sub End With
'Если изменилось не только имя, но и местоположение, то можно заменить весь путь ReplaceAllPath = MsgBox("Заменять весь путь? Нажмите ""Нет"", чтобы заменить только имя файла", vbYesNo + vbInformation, "Изменение ссылок") = vbYes
NewFileName = Replace(NewFileName, "\", "\\") 'Перебираем все поля в документе For Each oFld In ActiveDocument.Fields If oFld.Type = wdFieldLink Then 'Если поле является полем ссылки FieldCode = oFld.Code.Text If InStr(oFld.Code.Text, "Excel.SheetMacroEnabled.12") <> 0 And InStr(FieldCode, "\\" & OldFileName) <> 0 Then 'Если поле ссылается на лист Excel и на нужный файл If ReplaceAllPath Then 'Если нужно заменить весь путь StartPath = InStr(FieldCode, ":\\") - 2 EndPath = InStr(FieldCode, "\\" & OldFileName) + Len(OldFileName) + 2 FieldCode = Mid(FieldCode, 1, StartPath) & NewFileName & Mid(FieldCode, EndPath) Else 'Если нужно заменить только имя файла FieldCode = Replace(FieldCode, OldFileName, Mid(NewFileName, InStrRev(NewFileName, "\") + 1)) End If End If oFld.Code.Text = FieldCode End If Next End Sub
Здравствуйте стоит такая задача. Необходимо связать файл WORD с EXEL, с определенным файлом для подтягивания диаграмм. Но чтобы была возможность поменять файл EXEL и данные в WORDавтоматически подтянулись. Например есть файл "док 1" (в приложении) там есть диаграмма она автоматически связана с файлом "Книга 5". Нужно сделать так чтобы можно было автоматически подтянуть данные, например выбрал файл "Книгу 2", диаграмма в "Док 1" должна автоматически обновится. Помогите очень нужно Также важно чтобы в диаграммах не менялся исходный формат диаграмм, то есть они не становились больше или меньше, уже или шире.. Нашел на просторах вот такой макрос:
Sub Смена_источника_данных() ' ' Смена_источника_данных Макрос ' Dim oFld As Field 'Поле Dim OldFileName As String 'Старое имя файла Dim NewFileName As String 'Новое имя файла Dim FieldCode As String 'Код поля Dim ReplaceAllPath As Boolean 'Заменять весь путь к файлу или только имя Dim StartPath As Integer, EndPath As Integer 'Начало и конец пути к файлу в коде поля Dim FullPath As String Dim Name As String
For Each oFld In ActiveDocument.Fields If oFld.Type = wdFieldLink Then 'Если поле является полем ссылки If InStr(oFld.Code.Text, "Excel.SheetMacroEnabled.12") <> 0 Then 'Если поле ссылается на лист Excel FullPath = oFld.Code.Text Exit For End If End If Next
'Отделение имени файла от мусора i = InStrRev(FullPath, "\\") 'позиция последнего \\ Name = Mid(FullPath, i + 2) j = InStrRev(Name, Chr(34)) 'позиция конца имени файла с расширением OldFileName = Left(Name, j - 1)
'Ввод старого имени файла OldFileName = InputBox("Укажите старое имя файла с расширением в ссылке, которое нужно изменить", "Изменение ссылок", OldFileName) If Len(OldFileName) = 0 Then Exit Sub
'Выбор нового файла With Application.FileDialog(msoFileDialogFilePicker) .Title = "Выберите новый файл, с которым должен быть связан документ" .AllowMultiSelect = False .ButtonName = "Выбрать" .Filters.Clear .Filters.Add "Таблицы Excel", "*.xls; *.xlsx; *.xlsm" If .Show Then NewFileName = .SelectedItems(1) Else Exit Sub End With
'Если изменилось не только имя, но и местоположение, то можно заменить весь путь ReplaceAllPath = MsgBox("Заменять весь путь? Нажмите ""Нет"", чтобы заменить только имя файла", vbYesNo + vbInformation, "Изменение ссылок") = vbYes
NewFileName = Replace(NewFileName, "\", "\\") 'Перебираем все поля в документе For Each oFld In ActiveDocument.Fields If oFld.Type = wdFieldLink Then 'Если поле является полем ссылки FieldCode = oFld.Code.Text If InStr(oFld.Code.Text, "Excel.SheetMacroEnabled.12") <> 0 And InStr(FieldCode, "\\" & OldFileName) <> 0 Then 'Если поле ссылается на лист Excel и на нужный файл If ReplaceAllPath Then 'Если нужно заменить весь путь StartPath = InStr(FieldCode, ":\\") - 2 EndPath = InStr(FieldCode, "\\" & OldFileName) + Len(OldFileName) + 2 FieldCode = Mid(FieldCode, 1, StartPath) & NewFileName & Mid(FieldCode, EndPath) Else 'Если нужно заменить только имя файла FieldCode = Replace(FieldCode, OldFileName, Mid(NewFileName, InStrRev(NewFileName, "\") + 1)) End If End If oFld.Code.Text = FieldCode End If Next End Sub