Форум пользователей Visio http://visio.getbb.ru/ |
|
Замена текста в нескольких файлах по таблице соответствия http://visio.getbb.ru/viewtopic.php?f=6&t=1024 |
Страница 2 из 4 |
Автор: | AlexDen [ 24 сен 2016, 10:50 ] | |||
Заголовок сообщения: | Замена текста в нескольких файлах по таблице соответствия | |||
Добрый день ! Буду очень благодарен за помощь в решении задачи: 1. Есть схемы в формате "визио" с указанием адресов (это текстовые поля) элементов схемы. (Схема1) 2. Есть таблица соответствия неправильного текста - правильному, колонки А и В соответственно. Можно ли автоматизировать процесс поиска в нескольких схемах текста из колонки А и их замену на текст из колонки В ? Дополнено позднее: Тема получила свое продолжение в ветках обсуждения:
Find&Replace Addon For MS Visio Скорость обработки документов Visio из Excel
|
Автор: | Tumanov [ 25 сен 2016, 00:00 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Если не понятно, что происходит, то нужно открывать редактор VBA и идти по шагам. Но в первую очередь надо бы подправить фильтр имен файлов. Он и в том, и в другом коде настроен на .vsd, а у вас скорее всего .vsdx. Поэтому вот эту строчку Код: If Right(ss.Name, 4) = ".vsd" Then надо изменить на Код: If Right(ss.Name, 5) = ".vsdx" Then А дальше смотреть, на каком шаге вылетает или куда не заходит и сообщать здесь.
|
Автор: | Shishok [ 25 сен 2016, 00:20 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
В общем если адреса всегда на 10 начинаются то замени процедуру на: Код: Sub OpenVisioFile(PathName)
Dim oVisio As Object, oDoc As Object, oShapes As Object, oSh As Object Dim i As Integer Set oVisio = CreateObject("Visio.InvisibleApp") Set oDoc = oVisio.Documents.OpenEx(PathName, &H40) Set oShapes = oDoc.Pages.Item(1).Shapes For Each oSh In oShapes For i = 1 To UBound(arrRange, 1) If oSh.Characters.Text = arrRange(i, 1) Then oSh.Characters.Text = arrRange(i, 2) ElseIf Not oSh.Characters.Text Like "10.*" And oSh.Characters.Text Like "*" & arrRange(i, 1) & "*" Then oSh.Characters.Text = Replace(oSh.Characters.Text, arrRange(i, 1), arrRange(i, 2), 1) End If Next Next oDoc.Save oDoc.Close oVisio.Quit End Sub |
Автор: | Surrogate [ 25 сен 2016, 00:24 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Tumanov в сообщении #9750 писал(а): AlexDen все равно, похоже, учиться не хочет ! Не факт Tumanov в сообщении #9750 писал(а): Это его Surrogate напугал ну это кошерно-московские расценки в моей франшизе, любой из вас мог поставить более адекватный ценник Tumanov в сообщении #9750 писал(а): Деньжищи уплыли а вы сразу все свои |
Автор: | Shishok [ 25 сен 2016, 08:42 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Подкорректированный код: Код: Option Explicit
Dim Filenames As Collection Dim arrRange Const Path = "Диск:\Папка\Папка\Папка" Sub MainSub() Dim fs As Object, dd As Object, fc As Object, ss As Object Dim i As Integer arrRange = ActiveSheet.UsedRange Set Filenames = New Collection Set fs = CreateObject("Scripting.FileSystemObject") Set dd = fs.GetFolder(Path) Set fc = dd.Files For Each ss In fc If ss.Name Like "*.vsd*" Then ' если имя файла содержит подстроку: .vsd, .vsdx, vsdm Filenames.Add ss.Name End If Next For i = 1 To Filenames.Count OpenVisioFile (Path & "\" & Filenames(i)) Next If i - 1 <> 0 Then MsgBox "Готово! Обработано " & i - 1 & " файлов.", vbInformation, "Замена текста" Else MsgBox "Нет файлов для обработки.", vbInformation, "Замена текста" End If End Sub Sub OpenVisioFile(PathName) Dim oVisio As Object, oDoc As Object, oShapes As Object, oSh As Object Dim i As Integer Set oVisio = CreateObject("Visio.InvisibleApp") Set oDoc = oVisio.Documents.OpenEx(PathName, &H40) Set oShapes = oDoc.Pages.Item(1).Shapes For Each oSh In oShapes With oSh.Characters If Len(.Text) > 0 Then ' если шейп содержит текст For i = 1 To UBound(arrRange, 1) If .Text = arrRange(i, 1) Then ' если текст шейпа полностью совпадает с проверочной строкой .Text = arrRange(i, 2) ' меняем текст полностью Exit For ' после замены выходим из цикла ElseIf Not .Text Like "#*#" And .Text Like "*" & arrRange(i, 1) & "*" Then ' если в начале и конце текста нет цифр и имеется совпадающая подстрока .Text = Replace(.Text, arrRange(i, 1), arrRange(i, 2), 1) ' меняем совпадающую подстроку Exit For ' после замены выходим из цикла End If Next End If End With Next oDoc.Save oDoc.Close oVisio.Quit End Sub |
Автор: | Shishok [ 25 сен 2016, 09:08 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Код конечно рабочий, но при наличии "сотен схем и тысяч строк" для проверки он будет чрезвычайно "долгоиграющий". Что касается адресов Ip, концепцию надо менять. Брать текст из шейпа и методом Selection.Find искать в таблице Excel, в первом столбце и при успехе заменять. Но с фамилиями это не прокатит. |
Автор: | AlexDen [ 25 сен 2016, 09:38 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Shishok писал(а): AlexDen у тебя там адреса всегда на 10.xxxxxxx начинаются? Адреса разные могут быть. Вообще имелся ввиду любой совпавший текст (адрес, фио, телефон ...). Ну никак лыжи не едут ... Не хочет у меня работать. Пробовал пошаговое выполнение (F8) - циклится Sub MainSub() и в окошке Immediate пусто. |
Автор: | Shishok [ 25 сен 2016, 09:55 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Сообщения об ошибках вылетают? |
Автор: | AlexDen [ 25 сен 2016, 09:59 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Заработало !!! |
Автор: | Shishok [ 25 сен 2016, 10:14 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Усовершенствуем код. Должен быть выигрыш во времени обработки файлов при большом количестве данных для проверки: Код: Option Explicit
Dim Filenames As Collection Dim arrRange, adr As String Const Path = "D:\MY CONTENT\Google Диск\Примеры\Замена текста" Sub MainSub() Dim fs As Object, dd As Object, fc As Object, ss As Object Dim i As Integer adr = Range("A1", Cells(ActiveSheet.UsedRange.Rows.Count, "A")).Address ' адрес ячеек первого столбца с данными arrRange = ActiveSheet.UsedRange ' весь диапазон с данными заносим в массив Set Filenames = New Collection Set fs = CreateObject("Scripting.FileSystemObject") Set dd = fs.GetFolder(Path) Set fc = dd.Files For Each ss In fc If ss.Name Like "*.vsd*" Then ' если имя файла содержит подстроку: .vsd, .vsdx, vsdm Filenames.Add ss.Name End If Next For i = 1 To Filenames.Count OpenVisioFile (Path & "\" & Filenames(i)) Next If i - 1 <> 0 Then MsgBox "Готово! Обработано " & i - 1 & " файлов.", vbInformation, "Замена текста" Else MsgBox "Нет файлов для обработки.", vbInformation, "Замена текста" End If End Sub Sub OpenVisioFile(PathName) Dim oVisio As Object, oDoc As Object, oShapes As Object, oSh As Object Dim i As Integer, txt As String Set oVisio = CreateObject("Visio.InvisibleApp") Set oDoc = oVisio.Documents.OpenEx(PathName, &H40) Set oShapes = oDoc.Pages.Item(1).Shapes For Each oSh In oShapes With oSh.Characters If Len(.Text) > 0 Then ' если шейп содержит текст If .Text Like "#*#" Then ' если в начале и конце текста есть цифры (ip адрес, телефон) txt = FindText(.Text) If txt <> "" Then .Text = txt ' если что-то найдено, то меняем Else For i = 1 To UBound(arrRange, 1) If .Text Like "*" & arrRange(i, 1) & "*" Then ' если имеется совпадающая подстрока .Text = Replace(.Text, arrRange(i, 1), arrRange(i, 2), 1) ' меняем совпадающую подстроку Exit For ' после замены выходим из цикла End If Next End If End If End With Next oDoc.Save oDoc.Close oVisio.Quit End Sub Private Function FindText(txt) ' функция поиска txt в первом столбце таблицы Dim fi With Worksheets(1).Range(adr) Set fi = .Find(txt, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) If Not fi Is Nothing Then FindText = .Cells(fi.Row, 2).Value End With End Function |
Автор: | Tumanov [ 25 сен 2016, 10:30 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Вообще-то... Я не уверен, что стоит совершенствовать решение с поиском и заменой. Достаточно, что оно один раз отработает. В любом случае это будет всего лишь костыль. А дальше надо бы рассмотреть возможность построения нормального решения - с подключением к данным. То есть база и множество подключенных схем (это если не удастся дойти до автопостроения схем). Возможно придется написать скрипт экспорта, который создаст базу по имеющимся схемам. Но в первую очередь нужно бы видеть, что из себя представляет схема. Не пример из трех шейпов, а нечто более реальное. Если это получится, то в случае изменений сценарий станет другим. Сначала изменяется база (там возможны запросы, групповые операции). Потом обновляются данные в схемах. |
Автор: | 9rey [ 25 сен 2016, 10:31 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Shishok обязательно на каждом новом файле создавать объект визио и потом его убивать? Код: Set oVisio = CreateObject("Visio.InvisibleApp") это же куча времени уходит. может создать один раз в начале кода и убить в конце?
.... oVisio.Quit |
Автор: | Shishok [ 25 сен 2016, 10:49 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
9rey писал(а): Shishok обязательно на каждом новом файле создавать объект визио и потом его убивать? Код: Set oVisio = CreateObject("Visio.InvisibleApp") это же куча времени уходит. может создать один раз в начале кода и убить в конце?.... oVisio.Quit Совершенно верно. Я об этом думал, но... забыл. |
Автор: | AlexDen [ 25 сен 2016, 11:25 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Спасибо всем за горячую поддержку ! Вы быстрее пишете код, чем я его проверять успеваю ) Хотелось бы еще визуализировать произведенные замены и сохранять измененный файл с добавление к старому имени суффикса (new). |
Автор: | AlexDen [ 25 сен 2016, 11:41 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
А еще не производит замену на "закладках" файла визио. Можно заставить скрипт закладки проверять ? |
Автор: | Shishok [ 25 сен 2016, 11:52 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Цитата: Хотелось бы еще визуализировать произведенные замены и сохранять измененный файл с добавление к старому имени суффикса (new). Как визуализировать? Цитата: А еще не производит замену на "закладках" файла визио. Что это за закладки? |
Автор: | Surrogate [ 25 сен 2016, 11:57 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Страницы документа наверно |
Автор: | Shishok [ 25 сен 2016, 12:26 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Что значит визуализировать - не понял. По-понятнее пожалуйста. Код: Option Explicit
Dim Filenames As Collection Dim arrRange, adr As String, oVisio As Object Const Path = "D:\MY CONTENT\Google Диск\Примеры\Замена текста" Sub MainSub() Dim fs As Object, dd As Object, fc As Object, ss As Object Dim i As Integer adr = Range("A1", Cells(ActiveSheet.UsedRange.Rows.Count, "A")).Address ' адрес ячеек первого столбца с данными arrRange = ActiveSheet.UsedRange ' весь диапазон с данными заносим в массив Set Filenames = New Collection Set fs = CreateObject("Scripting.FileSystemObject") Set dd = fs.GetFolder(Path) Set fc = dd.Files For Each ss In fc If ss.Name Like "*.vsd*" Then ' если имя файла содержит подстроку: .vsd, .vsdx, vsdm Filenames.Add ss.Name End If Next Set oVisio = CreateObject("Visio.InvisibleApp") For i = 1 To Filenames.Count OpenVisioFile (Path & "\" & Filenames(i)) Next oVisio.Quit Set oVisio = Nothing If i - 1 <> 0 Then MsgBox "Готово! Обработано " & i - 1 & " файлов.", vbInformation, "Замена текста" Else MsgBox "Нет файлов для обработки.", vbInformation, "Замена текста" End If End Sub Sub OpenVisioFile(PathName) Dim oDoc As Object, oPages As Object, oSh As Object Dim i As Integer, j As Integer, txt As String Set oDoc = oVisio.Documents.OpenEx(PathName, &H40) Set oPages = oDoc.Pages For j = 1 To oPages.Count ' перебор страниц досумента For Each oSh In oPages.Item(j).Shapes ' перебор шейпов на листе With oSh.Characters If Len(.Text) > 0 Then ' если шейп содержит текст If .Text Like "#*#" Then ' если в начале и конце текста есть цифры (ip адрес, телефон) txt = FindText(.Text) If txt <> "" Then .Text = txt ' если что-то найдено, то меняем Else For i = 1 To UBound(arrRange, 1) If .Text Like "*" & arrRange(i, 1) & "*" Then ' если имеется совпадающая подстрока .Text = Replace(.Text, arrRange(i, 1), arrRange(i, 2), 1) ' меняем совпадающую подстроку Exit For ' после замены выходим из цикла End If Next End If End If End With Next Next Dim pn As String pn = Replace(PathName, ".vsd", "_new.vsd", 1) oDoc.SaveAsEx pn, 2 ' сохранить под новым именем oDoc.Close End Sub Private Function FindText(txt) ' функция поиска txt в первом столбце таблицы Dim fi With Worksheets(1).Range(adr) Set fi = .Find(txt, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) If Not fi Is Nothing Then FindText = .Cells(fi.Row, 2).Value End With End Function |
Автор: | Tumanov [ 25 сен 2016, 12:59 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
В общем случае, конечно, надо бы и внутри групп шейпы проверить (на один уровень или до бесконечности). Но для конкретной задачи может быть этого и не надо. |
Автор: | AlexDen [ 25 сен 2016, 13:06 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Прошу прощения за местный слэнг. Закладки - это страницы документа. Да сейчас все страницы меняет. Вложенность текста любая может быть ? Например если шейпы сгруппированы ? Визуализировать - показать в MsgBox в каком файле что поменялось. |
Автор: | Tumanov [ 25 сен 2016, 13:18 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Цитата: показать в MsgBox в каком файле что поменялось Если существуют сотни документов и тысячи замен (как упоминалось в начале "Таблица соответствия адресов - это несколько тысяч строк, схем- сотни"), то на MsgBox это как-то не тянет. Тут уже больше подошел бы протокол обработки, лог-файл. |
Страница 2 из 4 | Часовой пояс: UTC + 3 часа [ Летнее время ] |
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group http://www.phpbb.com/ |