Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 30.08.2010, 13:32   #11
Василий.
Пользователь
 
Регистрация: 28.08.2010
Сообщений: 16
По умолчанию

не работает ... у меня не одна ссылка, может поэтому?
Василий. вне форума Ответить с цитированием
Старый 19.04.2014, 12:27   #12
SirSAS
 
Регистрация: 30.12.2010
Сообщений: 8
По умолчанию

Цитата:
Сообщение от viter.alex Посмотреть сообщение
Попробуй такой. Писал не для разогрева, а давным-давно.
viter.alex Благодарю! 4 года прошло, а работает
Единственное как оказалось в цикле была досадная ошибка, которая приводила к порче всех остальных кодов, перекрестных ссылок в документе и напрягал постоянный ввод старого имени файла, поэтому исправил и немного дополнил, может кому пригодится:

Код:
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

Последний раз редактировалось SirSAS; 19.04.2014 в 14:02.
SirSAS вне форума Ответить с цитированием
Старый 20.04.2014, 11:56   #13
SirSAS
 
Регистрация: 30.12.2010
Сообщений: 8
По умолчанию

По мере разбора полетов и всестороннего тестирования наткнулся еще на некоторые сюрпризы, которые подбросил word 2013 (возможно и в других версиях, с чем связано не понял):
Word при помещении файла в далекую папку, например W:\02_works\01_НЦТО-Нск\06_Экспертиза ПБ\2014\ОАО ВНК Томскнефть\ФА\АГЗУ-Первомайское-к17.docx полный путь ссылки помещает в кавычки "W:\..." (без кавычек ошибка), а при перемещении например в C:\soft\АГЗУ-Первомайское-к17.docx уже без кавычек.
А так как есть необходимость в том, чтобы макросом пользовались люди, которые с компьютером на Вы, пришлось дополнительно заняться автоматизацией и обработкой всевозможных ошибок.

Были поставлены задачи:
1. Проводить синхронизацию автоматически (только в том случае, если файл был перемещен или переименован или то и другое)
2. Обрабатывать разные типы ошибок и выводить код ошибки для оценки возможных сбоев в работе
3. Минимизировать вмешательство человека в работу скрипта
4. Разрешить ситуацию с кавычками, описанную выше.

Так как связи word->exel->word в моем случае двусторонние, то есть следующее ограничение:
1. Для правильной синхронизации рабочие файлы *.docx и *.xlsm (или *.xlsх) должны находится в одной папке, названия файлов должны совпадать

И второе ограничение, которое можно обойти наверное при помощи Application.FileDialog, но я любитель и разбираться долго не стал, поэтому:
2. В документе должна присутствовать закладка с именем Путь_файла на поле { FILENAME \p } (Текст -> Поле -> FileName, установить галочку Добавить путь к имени файла)

Получился следующий функционал:
При запуске вордовского файла происходит автоматическое срабатывание скрипта Sub AutoOpen(), скрипт сравнивает пути, имена файлов и наличие сообщений об ошибках, при полном соответствии путей и отсутствии сообщений работа скрипта останавливается и пользователь практически не замечает его запуск. При наличии несоответствий и (или) ошибок выдаются окна о начале и прохождении синхронизации с указанием кодов по которым при необходимости можно оценить тип ошибок и несоответствий.

Модифицированный скрипт привожу ниже, к сожалению код грязный:
SirSAS вне форума Ответить с цитированием
Старый 20.04.2014, 12:05   #14
SirSAS
 
Регистрация: 30.12.2010
Сообщений: 8
По умолчанию

Код:
Sub AutoOpen()
'
' Смена_источника_данных Макрос
'
  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 PathСompare1 As String
  Dim PathСompare2 As String
  Dim Name As String
  TextError = 0

  If ActiveWindow.View.ShowFieldCodes = True Then
     ActiveWindow.View.ShowFieldCodes = False
  End If
  ActiveDocument.Fields.Update
  ActiveDocument.Bookmarks("\StartOfDoc").Select
  
 '''''''''''''''''''''''''''
 'проверка Ошибки связи
       With Selection.Find
        .Text = "Ошибка! Ошибка связи"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
            If .Execute Then TextError = 1
       End With
       
 'проверка Ошибки раздела
       With Selection.Find
        .Text = "Ошибка! Раздел не указан"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
            If .Execute Then TextError = 2
       End With
 ''''''''''''''''''''''''''''
  
     PathСompare1 = Replace(ActiveDocument.Bookmarks("Путь_файла").Range, "\", "\\")
     m = InStrRev(PathСompare1, ".") 'позиция начала расширения файла
     n = InStrRev(PathСompare1, "\\") 'позиция последнего \\
     PathСompare1 = Left(PathСompare1, m - 1)
     PathСompare11 = Left(PathСompare1, n - 1) 'только путь для сравнения
     
    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, "\\") 'позиция последнего \\
  k = InStr(FullPath, "\\") 'позиция первого \\
  m = InStrRev(FullPath, ".") 'позиция начала расширения файла
  Name = Mid(FullPath, i + 2)
  PathСompare2 = Left(FullPath, m - 1)
  PathСompare21 = Left(FullPath, i - 1)
  PathСompare2 = Mid(PathСompare2, k - 2)
  PathСompare21 = Mid(PathСompare21, k - 2) 'только путь для сравнения
  j = InStrRev(Name, ".") 'позиция конца имени файла с расширением
  OldFileName = Left(Name, j + 4)
   
  If StrComp(PathСompare1, PathСompare2) = 0 And TextError = 0 Then   'Если при открытии документа пути и имена файлов совпадают с привязками в кодах
    'MsgBox ("Код: " & StrComp(PathСompare1, PathСompare2) & TextError & vbCr & "Пути и имена файлов совпадают с привязками в кодах. Действий по синхронизации не требуется!")
  Else 'Если при открытии документа пути и имена файлов НЕ совпадают с привязками в кодах
    If TextError = 2 Then
        MsgBox ("Код: " & StrComp(PathСompare11, PathСompare21) & TextError & vbCr & vbCr & "ВНИМАНИЕ!!! Обнаружена ошибка раздела!" & vbCr & "Вероятная причина - нарушение структуры в коде привязки. Проверьте коды привязок на отсутствие двойных кавычек." & vbCr & vbCr & "Alt+F9 - Показать значения полей")
        Exit Sub
    Else
        MsgBox ("Код: " & StrComp(PathСompare11, PathСompare21) & TextError & vbCr & "Пути и имена файлов НЕ совпадают с привязками в кодах. Будет проведена синхронизация!" & vbCr & vbCr & "ВНИМАНИЕ!!! Для правильной синхронизации рабочие файлы *.docx и *.xlsm должны находится в одной папке, названия файлов должны совпадать!" & vbCr & vbCr & "Alt+U - Запустить синхронизацию повторно")
    End If
  'Ввод старого имени файла
  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 
' Продолжение следует

Последний раз редактировалось SirSAS; 20.04.2014 в 12:51.
SirSAS вне форума Ответить с цитированием
Старый 20.04.2014, 12:07   #15
SirSAS
 
Регистрация: 30.12.2010
Сообщений: 8
По умолчанию

Код:
 If StrComp(PathСompare11, PathСompare21) <> 0 Then 'Если изменилось не только имя, но и местоположение, то заменяем весь путь   
ReplaceAllPath = MsgBox("ВНИМАНИЕ!!! В связи с тем, что файлы были перемещены, в связанных полях будут заменены все пути!", OKOnly + vbInformation, "Изменение ссылок") = vbOK
  End If
    
  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 = True Then 'Если нужно заменить весь путь
            StartPath = InStr(FieldCode, ":\\") - 2
            EndPath = InStr(FieldCode, "\\" & OldFileName) + Len(OldFileName) + 2
            If InStr(oFld.Code.Text, Chr(34)) <> 0 Then 'Если путь в поле заключен в кавычки
                FieldCode = Mid(FieldCode, 1, StartPath) & NewFileName & Mid(FieldCode, EndPath)
            Else 'Если путь в поле не помещен в кавычки
                FieldCode = Mid(FieldCode, 1, StartPath) & Chr(34) & NewFileName & Chr(34) & Mid(FieldCode, EndPath)
            End If
        Else 'Если нужно заменить только имя файла
          FieldCode = Replace(FieldCode, OldFileName, Mid(NewFileName, InStrRev(NewFileName, "\") + 1))
        End If
      End If
      oFld.Code.Text = FieldCode
    End If
  Next
  
  TextError = 0
  ActiveDocument.Fields.Update

  
 '''''''''''''''''''''''''''
 'проверка Ошибки связи
       With Selection.Find
        .Text = "Ошибка! Ошибка связи"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
            If .Execute Then TextError = 1
       End With

 'проверка Ошибки раздела
       With Selection.Find
        .Text = "Ошибка! Раздел не указан"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
            If .Execute Then TextError = 2
       End With
 '''''''''''''''''''''''''''''

       If TextError <> 0 Then 'Ошибка связи или раздела
          MsgBox ("Код: 2" & TextError & vbCr & "Внимание!!! Ошибка синхронизации!" & vbCr & vbCr & "Проверьте выполнение следующих условий:" & vbCr & "1.Рабочие файлы *.docx и *.xlsm должны находится в одной папке." & vbCr & "2.Названия файлов должны совпадать." & vbCr & vbCr & "Alt+U - Запустить синхронизацию повторно")
        Else 'Синхронизация прошла успешно
          MsgBox ("Код: 00" & vbCr & "Синхронизация прошла успешно!")
        End If

  End If
End Sub
SirSAS вне форума Ответить с цитированием
Старый 27.07.2016, 16:57   #16
_Ник_
Новичок
Джуниор
 
Регистрация: 27.07.2016
Сообщений: 1
Вопрос

Цитата:
Сообщение от SirSAS Посмотреть сообщение
Код:
 If StrComp(PathСompare11, PathСompare21) <> 0 Then 'Если изменилось не только имя, но и местоположение, то заменяем весь путь   
ReplaceAllPath = MsgBox("ВНИМАНИЕ!!! В связи с тем, что файлы были перемещены, в связанных полях будут заменены все пути!", OKOnly + vbInformation, "Изменение ссылок") = vbOK
  End If
    
  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 = True Then 'Если нужно заменить весь путь
            StartPath = InStr(FieldCode, ":\\") - 2
            EndPath = InStr(FieldCode, "\\" & OldFileName) + Len(OldFileName) + 2
            If InStr(oFld.Code.Text, Chr(34)) <> 0 Then 'Если путь в поле заключен в кавычки
                FieldCode = Mid(FieldCode, 1, StartPath) & NewFileName & Mid(FieldCode, EndPath)
            Else 'Если путь в поле не помещен в кавычки
                FieldCode = Mid(FieldCode, 1, StartPath) & Chr(34) & NewFileName & Chr(34) & Mid(FieldCode, EndPath)
            End If
        Else 'Если нужно заменить только имя файла
          FieldCode = Replace(FieldCode, OldFileName, Mid(NewFileName, InStrRev(NewFileName, "\") + 1))
        End If
      End If
      oFld.Code.Text = FieldCode
    End If
  Next
  
  TextError = 0
  ActiveDocument.Fields.Update

  
 '''''''''''''''''''''''''''
 'проверка Ошибки связи
       With Selection.Find
        .Text = "Ошибка! Ошибка связи"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
            If .Execute Then TextError = 1
       End With

 'проверка Ошибки раздела
       With Selection.Find
        .Text = "Ошибка! Раздел не указан"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
            If .Execute Then TextError = 2
       End With
 '''''''''''''''''''''''''''''

       If TextError <> 0 Then 'Ошибка связи или раздела
          MsgBox ("Код: 2" & TextError & vbCr & "Внимание!!! Ошибка синхронизации!" & vbCr & vbCr & "Проверьте выполнение следующих условий:" & vbCr & "1.Рабочие файлы *.docx и *.xlsm должны находится в одной папке." & vbCr & "2.Названия файлов должны совпадать." & vbCr & vbCr & "Alt+U - Запустить синхронизацию повторно")
        Else 'Синхронизация прошла успешно
          MsgBox ("Код: 00" & vbCr & "Синхронизация прошла успешно!")
        End If

  End If
End Sub
Добрый день!

Макрос выдает Run time error "5"
Если нажать Debug желтым подсвечивается вот эта строка
PathСompare2 = Left(FullPath, m - 1)

В чем может быть причина?
Спасибо
_Ник_ вне форума Ответить с цитированием
Старый 24.11.2018, 20:29   #17
DJPetjko
Новичок
Джуниор
 
Регистрация: 24.11.2018
Сообщений: 1
По умолчанию

Что бы не плодить новые темы похожими вопросами спрошу тут:
Есть вордовский документ при открытии которого появляется диалоговое окно выбора источника данных для слияния(один основной *.docx и много разных *.xlsx в разных местах). Со временем появилась необходимость внести кое какие изменения в ворде, всё получилось, слияние работает, но пропало диалоговое окно выбора источника данных. Вытянул на панель кнопку "использование существующего списка" что бы как-то ускорить процесс слияния, но хотелось бы по старому - при открытии файла выбирать нужный файл.
Подскажите чайнику пожалуйста, как это осуществить? Спасибо
DJPetjko вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Макрос преобразовывающий таблицу из Word в Excel Alisya Microsoft Office Excel 20 15.10.2011 13:16
Макрос для одновременной работы с word и excel Virtour Microsoft Office Excel 1 20.07.2010 09:29
связи между файлами excel redfield Microsoft Office Excel 0 04.05.2010 16:22
Связи excel c word Vladymyr17 Microsoft Office Excel 0 28.09.2009 15:52
Обмен данных между Excel и Word WilliJo Microsoft Office Word 3 26.05.2009 00:19