Форум пользователей 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


Вложения:
1.rar [32.61 Кб]
Скачиваний: 159
IP адреса.xlsx [8.79 Кб]
Скачиваний: 135

Автор:  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/