Форум пользователей Visio http://visio.getbb.ru/ |
|
Замена текста в нескольких файлах по таблице соответствия http://visio.getbb.ru/viewtopic.php?f=6&t=1024 |
Страница 1 из 4 |
Автор: | AlexDen [ 24 сен 2016, 10:50 ] | |||
Заголовок сообщения: | Замена текста в нескольких файлах по таблице соответствия | |||
Добрый день ! Буду очень благодарен за помощь в решении задачи: 1. Есть схемы в формате "визио" с указанием адресов (это текстовые поля) элементов схемы. (Схема1) 2. Есть таблица соответствия неправильного текста - правильному, колонки А и В соответственно. Можно ли автоматизировать процесс поиска в нескольких схемах текста из колонки А и их замену на текст из колонки В ? Дополнено позднее: Тема получила свое продолжение в ветках обсуждения:
Find&Replace Addon For MS Visio Скорость обработки документов Visio из Excel
|
Автор: | Tumanov [ 24 сен 2016, 11:35 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Можно. Но программку писать придется. Значит, получится не так уж быстро. Так что надо будет оценивать, что быстрее - вручную или программно. В принципе, в одном документе можно провести поиск и замену по всем листам документа. И вроде бы даже с подстановками типа Any character. То есть в одном документе достаточно быстро получится. --- А программно... Считать табличку из Excel - не проблема. Перебрать файлы в папке - тоже. Дальше в объектной модели Visio: открыть файл, перебрать все страницы, перебрать все шейпы на странице - сравнивать текст с одной колонкой; если сравнился, менять на текст из другой колонки. Программку можно реализовать, например, как макрос в том самом Excel. Ну, это так, "в лоб". |
Автор: | AlexDen [ 24 сен 2016, 11:50 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Таблица соответствия адресов - это несколько тысяч строк, схем- сотни. Мрачная перспектива вручную это делать. От чего оттолкнуьтся - не знаю, не специалист по VBA ... может кто примером поможет. |
Автор: | Tumanov [ 24 сен 2016, 12:08 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Таких примеров скорее всего не будет. Задача не типовая. Можно подобрать примерчики для каждого из приведенных шагов... Но это уже не быстро. И если "не специалист в VBA", то боюсь, процесс серьезно затянется. Мне кажется, что в данном случае проще было бы заказать кому-нибудь разработку макроса. А в дальнейшем (при последующих изменениях) использовать его уже как пример. ---- А может еще не поздно и сменить подход? Такое впечатление, что в Ваших схемах нужно было использовать связь с данными. Тогда при изменении данных достаточно было бы просто нажать кнопку "Обновить". |
Автор: | Tumanov [ 24 сен 2016, 12:30 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Вот немного похожая задача. В одном документе разыскивались и подкрашивались фрагменты текста по определенному образцу. Код: Private regEx As VBScript_RegExp_55.RegExp
Private Match As VBScript_RegExp_55.Match Private Matches Private ArRes() 'Main procedure scans all pages, shapes and shapes in groups Public Sub ColorTags() Dim d As Visio.Document Dim p As Visio.Page Set d = ActiveDocument For i = 1 To d.Pages.Count 'Each page Set p = d.Pages(i) For j = 1 To p.Shapes.Count 'Each shape Dim Shp As Visio.Shape Set Shp = p.Shapes(j) If Shp.Type = visTypeGroup Then 'If shape is the group, then it scans contained shapes For k = 1 To Shp.Shapes.Count Dim shp2 As Visio.Shape Set shp2 = Shp.Shapes(k) ColorOneShape shp2 ' => color it Next ElseIf Shp.Type = visTypeShape Then 'Shape is not group ColorOneShape Shp ' => color it End If Next Next End Sub 'Searh tags in one shape and colors it Private Sub ColorOneShape(ByVal Shp As Visio.Shape) s = Shp.Text ar = GetTags(s) 'Get begin and end position for each tag If UBound(ar, 2) > 0 Then For m = 1 To UBound(ar, 2) Dim vChar As Visio.Characters Set vChar = Shp.Characters vChar.Begin = ar(1, m) 'Start position for current tag vChar.End = ar(2, m) 'End position for current tag vChar.CharProps(visCharacterColor) = 4 'Blue Next End If End Sub 'Get array of start and end position for each tag in string Private Function GetTags(ByVal s As String) As Variant ReDim ArRes(2, 0) Set regEx = New RegExp ' Create regular expression. regEx.Global = True regEx.pattern = "<[^<^>]*>" ' Set pattern "<Variable>" Set Matches = regEx.Execute(s) ' Execute search. MatchesToArray '=> regEx.pattern = "@[^ ]*\s" ' Set pattern "@Variable " Set Matches = regEx.Execute(s) MatchesToArray '=> Set regEx = Nothing GetTags = ArRes End Function 'Convert Match attributes (first, length) to array (start, end) Private Sub MatchesToArray() For Each Match In Matches ' Iterate Matches collection. Bound = UBound(ArRes, 2) + 1 ReDim Preserve ArRes(2, Bound) ArRes(1, Bound) = Match.FirstIndex ArRes(2, Bound) = Match.FirstIndex + Match.Length Next End Sub |
Автор: | AlexDen [ 24 сен 2016, 13:20 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
"Нам бы схемку, аль чертеж - мы б затеяли вертеж !" Спасибо за ответ, но как "мелкому специалисту" нужны уточнения. Этот код надо вставить с существующий файл "СХЕМА" и что дальше ? Можно рассказать, что он делает ? Его в визио надо вставить или в эксел ? Буду разбираться как код работает. А сколько может стоить решение задачи под ключ ? |
Автор: | Tumanov [ 24 сен 2016, 14:13 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Этот код приведен только как пример. Была немного похожая задача. Я скопировал оттуда текст макроса. Макрос работал в Visio по тому документу, в который он был вставлен. Если вставлять в Excel, то обращение к документу изменится. Вам интересна главная процедура Public Sub ColorTags(), в которой есть перебор шейпов в документе For i = 1 To d.Pages.Count - перебирает страницы For j = 1 To p.Shapes.Count - перебирает шейпы на странице Может потребоваться работа с регулярными выражениями Private regEx As VBScript_RegExp_55.RegExp Выборка текста из шейпа - s = Shp.Text Замены текста здесь нет, в этой задаче изменялся не текст, а его атрибуты. Вообще-то, смотрю сейчас, и вижу, что заимствовать можно будет не так уж много Одна процедура, да общий подход...) --------- Насчет "под ключ" - я могу только высказать свои соображения, а у исполнителя могут быть другие оценки. По моим прикидкам на первую работоспособную версию может уйти порядка двух часов работы. То есть в районе $30. Довольно часто после первой версии заказчику хочется еще что-то добавить, усовершенствовать. Понятно, что это можно делать до бесконечности... Прикидка, естественно, грубая и субъективная. Так, в качестве ориентира. Не исключено, что исполнитель может взять гораздо дешевле просто потому, что задача понравится и в надежде, что ее можно будет в дальнейшем тиражировать. |
Автор: | Surrogate [ 24 сен 2016, 15:18 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Я меньше чем за 7040р не берусь за работу. |
Автор: | Tumanov [ 24 сен 2016, 16:45 ] | ||
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия | ||
Ну или понемножку пошагово можно решать задачу прямо здесь. Глядишь на каждом шаге кто-нибудь да поможет... Первым делом явно надо из Excel файла добраться до списка нужных файлов. Для начала можно попробовать такой способ, как вот в этом примере. Макрос лезет в папку, в которой сам находится и выбирает оттуда все файлы с расширением .vsd в коллекцию Filenames. Потом выводит содержимое коллекции в окно Immediate. Код: Dim Filenames As Collection Sub MainSub() Set Filenames = New Collection Set fs = CreateObject("Scripting.FileSystemObject") s1 = CurDir Set dd = fs.GetFolder(s1) Set fc = dd.Files Dim fcou As Integer fcou = fc.Count i = 0 For Each ss In fc If Right(ss.Name, 4) = ".vsd" Then Filenames.Add ss.Name i = i + 1 End If Next TestPrint End Sub Sub TestPrint() For i = 1 To Filenames.Count Debug.Print Filenames(i) Next End Sub Следующим шагом (когда ученик освоит этот) нужно будет учиться открывать и закрывать документы Visio по этому списку. И т.д. Так сказать, совместим с процессом обучения. Глядишь, еще кому-то пригодится.
|
Автор: | Surrogate [ 24 сен 2016, 17:16 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Tumanov писал(а): Так сказать, совместим с процессом обучения. Глядишь, еще кому-то пригодится. если нет желания платить, мы можем бесплатно по |
Автор: | 9rey [ 24 сен 2016, 22:02 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
я бы разместил макрос в visio, из него бы открывал документ экселя и читал таблицу соответствий, с последующей заменой в схеме визио. в понедельник смогу пример кинуть, если найду на работе. |
Автор: | Tumanov [ 24 сен 2016, 22:07 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Цитата: я бы разместил макрос в visio Не очень хорошо, потому что файлы уже существуют и их очень много. А Excel - один. |
Автор: | Tumanov [ 24 сен 2016, 22:17 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Я, кстати, базовую весию дописал... AlexDen все равно, похоже, учиться не хочет. Деньжищи уплыли Это его Surrogate напугал Код: Dim Filenames As Collection
Dim CurrFolder As String Dim RenArr() Sub MainSub() GetRenArray Set Filenames = New Collection Set fs = CreateObject("Scripting.FileSystemObject") CurrFolder = Application.ActiveWorkbook.Path & "\" Set dd = fs.GetFolder(CurrFolder) Set fc = dd.Files Dim fcou As Integer fcou = fc.Count i = 0 For Each ss In fc If Right(ss.Name, 4) = ".vsd" Then Filenames.Add ss.Name i = i + 1 End If Next TestPrint End Sub Private Sub TestPrint() For i = 1 To Filenames.Count ProcessDocument (CurrFolder & Filenames(i)) Next End Sub Private Sub ProcessDocument(ByVal docPath As String) Dim vApp As Visio.InvisibleApp Dim doc As Visio.Document Set vApp = CreateObject("Visio.InvisibleApp") Set doc = vApp.Documents.Open(docPath) Debug.Print "Имя документа = " & doc.Name Debug.Print "Количество листов = " & doc.Pages.Count Dim p As Visio.Page For i = 1 To doc.Pages.Count 'Each page Set p = doc.Pages(i) For j = 1 To p.Shapes.Count 'Each shape Dim Shp As Visio.Shape Set Shp = p.Shapes(j) Debug.Print Shp.Text ReplaceText Shp Next Next doc.Save doc.Close vApp.Quit Set doc = Nothing Set vApp = Nothing End Sub Private Sub ReplaceText(ByVal Shp As Visio.Shape) s = Shp.Text For i = 1 To UBound(RenArr, 2) If StrComp(s, RenArr(1, i)) = 0 Then Shp.Text = RenArr(2, i) Exit For End If Next End Sub Private Sub GetRenArray() Dim r As Range Set r = Range("A1") Set reg = r.CurrentRegion Debug.Print reg.Rows.Count Debug.Print reg.Columns.Count rs = reg.Rows.Count cs = reg.Columns.Count ReDim RenArr(2, 12) For i = 1 To rs RenArr(1, i) = r.Offset(i - 1, 0) RenArr(2, i) = r.Offset(i - 1, 1) Next For i = 1 To UBound(RenArr, 2) Debug.Print RenArr(1, i), RenArr(2, i) Next End Sub |
Автор: | Shishok [ 24 сен 2016, 22:25 ] |
Заголовок сообщения: | 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 Right(ss.Name, 4) = ".vsd" Then Filenames.Add ss.Name End If Next For i = 1 To Filenames.Count OpenVisioFile (Path & "\" & Filenames(i)) Next 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.Application") 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 Like "*" & arrRange(i, 1) & "*" Then oSh.Characters.Text = Replace(oSh.Characters.Text, arrRange(i, 1), arrRange(i, 2), 1) Next Next oDoc.Save oDoc.Close oVisio.Quit End Sub |
Автор: | Tumanov [ 24 сен 2016, 22:48 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Мимо UsedRange я как-то проскочил. |
Автор: | Shishok [ 24 сен 2016, 23:13 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Косяк у меня в коде. Адрес 10.255.0.10 становится 10.221.0.110. А должен быть - 10.221.0.20. Оператор Like, в нем дело. |
Автор: | AlexDen [ 24 сен 2016, 23:33 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Хочет учиться AlexDen ! Положил файлы в с:\testFOLDERtest ( "Схема1" , "Схема2" и "IP адрес.xlsm") Const Path = "C:\testFOLDERtest\" в скрипт я вставил, но не понял что происходит |
Автор: | AlexDen [ 24 сен 2016, 23:44 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Shishok писал(а): Косяк у меня в коде. Адрес 10.255.0.10 становится 10.221.0.110. А должен быть - 10.221.0.20. Оператор Like, в нем дело. Почему-то не могу даже с ошибкой повторить ... |
Автор: | Shishok [ 24 сен 2016, 23:54 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
Цитата: Const Path = "C:\testFOLDERtest\" в скрипт я вставил, но не понял что происходит Последний слеш убери! То есть вот так - Const Path = "C:\testFOLDERtest" |
Автор: | Shishok [ 24 сен 2016, 23:58 ] |
Заголовок сообщения: | Re: Замена текста в нескольких файлах по таблице соответствия |
AlexDen у тебя там адреса всегда на 10.xxxxxxx начинаются? |
Страница 1 из 4 | Часовой пояс: UTC + 3 часа [ Летнее время ] |
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group http://www.phpbb.com/ |