Форум пользователей Visio

Форум по вопросам применения и программирования в Visio
Текущее время: 28 мар 2024, 23:32

Часовой пояс: UTC + 3 часа [ Летнее время ]


Правила форума


При размещении файлов предпочтительным является формат vsd (а не vsdx/vsdm)
Размещая ваши вложения на форуме не используйте имена файлов содержащих кириллицу, в противном случае файл будет иметь имя .<расширение файла> !

Для форматирования ваших сообщений используйте BBCodes, описание используемых на форуме BBCodes.



Начать новую тему Ответить на тему  [ Сообщений: 24 ]  На страницу 1, 2  След.
Автор Сообщение
 Заголовок сообщения: Разделить текст с сохранением форматирования
СообщениеДобавлено: 19 июл 2021, 23:29 
Не в сети
Бывалый

Зарегистрирован: 25 янв 2017, 11:40
Сообщений: 126
Использую Visio c: 2013
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Как разделить текст с сохранением форматирования с помощью VBA?

Имеется:
- многострочный форматированный текст;
- критерии для поиска: текст оканчивается на 1 или 2 или 3;

Логика:
- Найти текст который оканчивается на 1 или 2 или 3;
- Создать копию с сохранением форматирования справа от источника;
или
- Создать копию с сохранением форматирования справа от источника и ниже от предыдущего текста;

Прилагаю файл.


Вложения:
_Разбить_00.vsdx [22.26 Кб]
Скачиваний: 51
2021-07-19_22-20-26.png
2021-07-19_22-20-26.png [ 12.32 Кб | Просмотров: 564 ]
Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 01:16 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
andr писал(а):
критерии для поиска: текст оканчивается на 1 или 2 или 3;
и что точно не будет других условий? например переход на новую строку…

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 10:36 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
В секции Character каждое новое форматирование описывается новой строкой. То есть последовательно перечислены все изменения в форматировании. Вот на это и нужно ориентироваться.
Длины фрагментов там тоже указаныы.
Останется только установить соответствие между фрагментами, разделенными по форматированию, и фрагментами, разделенными по наличию цифры в конце.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 10:42 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
Tumanov писал(а):
В секции Character каждое новое форматирование описывается новой стркоой. Вот на это и нужно ориентироваться.
согласен. первая мысль была в этом направлении Running with Characters
Изображение
Но как вытянуть кодом значение в самом левом столбце (количество символов с этим образцом форматирования)?
Дополнено позднее: перебирал все 58 ячеек в строке CharProps раздела Characters (большинство из которых не используемые) - не нашел :wall:

Есть ещё нюанс, пользователю нужно следить за выделением последнего символа в строке. иначе может получиться одна цветная строка из N символов, один черный символ перевода строки, другая цветная строка. Из M символов
Содержимое спрятано под спойлер ↓
Спойлер:
откуда это появляется
Встроенное видео спрятано под спойлер ↓ Прямая ссылка на видео
Спойлер:
phpBB [media]

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 12:50 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
Вопрос неожиданно оказался интересным :)
Просмотр XML содержимого пакетного файла показал, что Visio нигде не хранит количества знаков в строке Characters. Значит, вычисляет их по ходу вывода ShapeSheet.
Пока придумал только один способ, как из VBA добраться до этой информации - последовательно просмотреть все позиции текста на предмет, к какой строке секции эта позиция относится.
Код:
Sub ttt()
    Dim shp As Visio.Shape
    Dim ch As Visio.Characters
    Set shp = ActiveWindow.Selection(1)
    Set ch = shp.Characters
    n = ch.CharCount
    nr = -1
    For i = 1 To n
        ch.Begin = i
        ch.End = i
        nrn = ch.CharPropsRow(0)
        If nr <> nrn Then
            nr = nrn
            Debug.Print i, nr
        End If
    Next
End Sub

По предложенному шейпу этот макрос дает такой вывод
Код:
1             0
10            1
19            2

Символы с 1 по 9 описываются строкой 0, с 10 по 18 - строкой 1 и с 19 до конца - строкой 2.
В принципе, для работы этого достаточно, хотя выглядит несколько коряво.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:01 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
В качестве подтверждения - вот что выводит мой Package Helper по этому шейпу. (Вернее, по странице, но на ней только один шейп).
Содержимое спрятано под спойлер ↓
Спойлер:
Код:
<?xml version='1.0' encoding='utf-8' ?>
<PageContents xmlns='http://schemas.microsoft.com/office/visio/2012/main' xmlns:r='http://schemas.openxmlformats.org/officeDocument/2006/relationships' xml:space='preserve'>
<Shapes>
<Shape ID='1' Type='Shape' LineStyle='1' FillStyle='1' TextStyle='3'>
<Cell N='PinX' V='0.9927823974895058'/>
<Cell N='PinY' V='10.78865402389366'/>
<Cell N='Width' V='0.770340799611111'/>
<Cell N='Height' V='0.7111656887478298'/>
<Cell N='LocPinX' V='0.3851703998055555' F='Width*0.5'/>
<Cell N='LocPinY' V='0.3555828443739149' F='Height*0.5'/>
<Cell N='Angle' V='0'/>
<Cell N='FlipX' V='0'/>
<Cell N='FlipY' V='0'/>
<Cell N='ResizeMode' V='0'/>
<Section N='Character'>
<Row IX='0'>
<Cell N='Color' V='#ff0000' F='THEMEGUARD(RGB(255,0,0))'/>
</Row>
<Row IX='1'>
<Cell N='Font' V='Themed' F='THEMEVAL()'/>
<Cell N='Color' V='#ffc000' F='THEMEGUARD(RGB(255,192,0))'/>
<Cell N='Style' V='Themed' F='THEMEVAL()'/>
<Cell N='Case' V='0'/>
<Cell N='Pos' V='0'/>
<Cell N='FontScale' V='1'/>
<Cell N='Size' V='0.1666666666666667'/>
<Cell N='DblUnderline' V='0'/>
<Cell N='Overline' V='0'/>
<Cell N='Strikethru' V='0'/>
<Cell N='DoubleStrikethrough' V='0'/>
<Cell N='Letterspace' V='0'/>
<Cell N='ColorTrans' V='0'/>
<Cell N='AsianFont' V='Themed' F='THEMEVAL()'/>
<Cell N='ComplexScriptFont' V='Themed' F='THEMEVAL()'/>
<Cell N='ComplexScriptSize' V='-1'/>
<Cell N='LangID' V='ru-RU'/>
</Row>
<Row IX='2'>
<Cell N='Font' V='Themed' F='THEMEVAL()'/>
<Cell N='Color' V='#00b050' F='THEMEGUARD(RGB(0,176,80))'/>
<Cell N='Style' V='Themed' F='THEMEVAL()'/>
<Cell N='Case' V='0'/>
<Cell N='Pos' V='0'/>
<Cell N='FontScale' V='1'/>
<Cell N='Size' V='0.1666666666666667'/>
<Cell N='DblUnderline' V='0'/>
<Cell N='Overline' V='0'/>
<Cell N='Strikethru' V='0'/>
<Cell N='DoubleStrikethrough' V='0'/>
<Cell N='Letterspace' V='0'/>
<Cell N='ColorTrans' V='0'/>
<Cell N='AsianFont' V='Themed' F='THEMEVAL()'/>
<Cell N='ComplexScriptFont' V='Themed' F='THEMEVAL()'/>
<Cell N='ComplexScriptSize' V='-1'/>
<Cell N='LangID' V='ru-RU'/>
</Row>
<Row IX='3'>
<Cell N='Font' V='Themed' F='THEMEVAL()'/>
<Cell N='Color' V='Themed' F='THEMEVAL()'/>
<Cell N='Style' V='Themed' F='THEMEVAL()'/>
<Cell N='Case' V='0'/>
<Cell N='Pos' V='0'/>
<Cell N='FontScale' V='1'/>
<Cell N='Size' V='0.1666666666666667'/>
<Cell N='DblUnderline' V='0'/>
<Cell N='Overline' V='0'/>
<Cell N='Strikethru' V='0'/>
<Cell N='DoubleStrikethrough' V='0'/>
<Cell N='Letterspace' V='0'/>
<Cell N='ColorTrans' V='0'/>
<Cell N='AsianFont' V='Themed' F='THEMEVAL()'/>
<Cell N='ComplexScriptFont' V='Themed' F='THEMEVAL()'/>
<Cell N='ComplexScriptSize' V='-1'/>
<Cell N='LangID' V='ru-RU'/>
</Row>
</Section>
<Section N='Geometry' IX='0'>
<Cell N='NoFill' V='0'/>
<Cell N='NoLine' V='0'/>
<Cell N='NoShow' V='0'/>
<Cell N='NoSnap' V='0'/>
<Cell N='NoQuickDrag' V='0'/>
<Row T='RelMoveTo' IX='1'>
<Cell N='X' V='0'/>
<Cell N='Y' V='0'/>
</Row>
<Row T='RelLineTo' IX='2'>
<Cell N='X' V='1'/>
<Cell N='Y' V='0'/>
</Row>
<Row T='RelLineTo' IX='3'>
<Cell N='X' V='1'/>
<Cell N='Y' V='1'/>
</Row>
<Row T='RelLineTo' IX='4'>
<Cell N='X' V='0'/>
<Cell N='Y' V='1'/>
</Row>
<Row T='RelLineTo' IX='5'>
<Cell N='X' V='0'/>
<Cell N='Y' V='0'/>
</Row>
</Section>
<Text>
<cp IX='0'/>
Строка-1>
<cp IX='1'/>
Строка-2>
<cp IX='2'/>
Строка-3<cp IX='3'/>
</Text>
</Shape>
</Shapes>
</PageContents>


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:15 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
Tumanov писал(а):
В принципе, для работы этого достаточно
Вполне рабочий вариант, я не знал за CharPropsRow. Хотел даже посимвольно перебирать. вот только в тексте могут быть разные шрифты, размеры, курсивы и т.п. и опять же их сочетания
Дополнено позднее: кстати ваш вариант очень похож на вариант, который посоветовала дама из M$FT (пример из SDK Visio 2003)
https://www.office-forums.com/threads/getting-shapesheets-character-section-info-in-vb.1616220/post-5057620

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:22 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
Цитата:
вот только в тексте могут быть разные шрифты, размеры, курсивы и т.п. и опять же их сочетания

Как только появится другой шрифт или размер или что-то еще, Visio обязательно оформит это отдельной строкой в секции Characters. То есть может получиться так, что нужный фрагмент текста (с циферкой на конце) будет оформлен не одной, а несколькими строками в Characters. Ну так это я и назвал синхронизацией - установить соответствие между нужными фрагментами и строками секции. Оно может быть как один к одному, так и один ко многим и наоборот. Но установить его можно.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:26 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
Но с другой стороны, сама исходная задача ставится неверно. Да, ее можно решить. Но правильно было бы не выковыривать информацию из текста, а заранее упаковать ее в данные, а в шейпе просто отобразить эти данные разным форматом. В таком случае "разделить" шейп было бы гораздо проще. То есть ошибка в выборе подхода. А уже она заставляет "героически преодолевать трудности".


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:33 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
Tumanov писал(а):
То есть ошибка в выборе подхода. А уже она заставляет "героически преодолевать трудности".
мне однажды поставили подобную задачу. нужно было из текста фигур Visio находить фрагменты с отличающимся написанием. перенести их в Word, и применить к ним некие стили. Мне тогда удалось послать того кто просил :)

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:39 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
Цитата:
Мне тогда удалось послать того кто просил

Ну это, может, и зря...
Бывает ведь и подход типа "любой каприз за ваши деньги".
Другое дело, что представляя всю задачу в целом, следует выбирать более прямые пути. Более соответствующие методам, используемым в выбранных инструментах.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 13:55 
Не в сети
Бывалый

Зарегистрирован: 25 янв 2017, 11:40
Сообщений: 126
Использую Visio c: 2013
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Tumanov писал(а):
Вопрос неожиданно оказался интересным :)
Просмотр XML содержимого пакетного файла показал, что Visio нигде не хранит количества знаков в строке Characters. Значит, вычисляет их по ходу вывода ShapeSheet.
Пока придумал только один способ, как из VBA добраться до этой информации - последовательно просмотреть все позиции текста на предмет, к какой строке секции эта позиция относится.
Код:
Sub ttt()
    Dim shp As Visio.Shape
    Dim ch As Visio.Characters
    Set shp = ActiveWindow.Selection(1)
    Set ch = shp.Characters
    n = ch.CharCount
    nr = -1
    For i = 1 To n
        ch.Begin = i
        ch.End = i
        nrn = ch.CharPropsRow(0)
        If nr <> nrn Then
            nr = nrn
            Debug.Print i, nr
        End If
    Next
End Sub

По предложенному шейпу этот макрос дает такой вывод
Код:
1             0
10            1
19            2

Символы с 1 по 9 описываются строкой 0, с 10 по 18 - строкой 1 и с 19 до конца - строкой 2.
В принципе, для работы этого достаточно, хотя выглядит несколько коряво.


Не могли бы чуток подробнее описать, что делать дальше?
Если не кодом, то хотя бы словами...


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 14:03 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
Tumanov писал(а):
Ну это, может, и зря...
ну там ждали, что я смогу это сделать за 2 часа.
Tumanov писал(а):
Бывает ведь и подход типа "любой каприз за ваши деньги".
за зарплату.
andr писал(а):
Не могли бы чуток подробнее описать, что делать дальше?
в каком смысле ?

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 14:52 
Не в сети
Бывалый

Зарегистрирован: 25 янв 2017, 11:40
Сообщений: 126
Использую Visio c: 2013
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Surrogate писал(а):
Tumanov писал(а):
andr писал(а):
Не могли бы чуток подробнее описать, что делать дальше?
в каком смысле ?

Как получить текст с форматированием?
Как найти в нём строку по критерию?

Если просто делать через запись макроса, то форматирование сохраняется....
Может после строчки `vsoCharacters1.Copy` можно как-то работать с текстом?


Код
Код:
    Dim vsoCharacters1 As Visio.Characters
    Set vsoCharacters1 = Application.ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    vsoCharacters1.Begin = 0
    vsoCharacters1.End = 27
   
    vsoCharacters1.Copy


    Application.ActiveWindow.Page.Paste


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 15:34 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
Цитата:
Как получить текст с форматированием?

В Visio нет объекта, совмещающего текст с форматированием, кроме шейпа. Так что, получить нельзя. Можно получить текст, можно форматирование отдельно.
У Вас скорее всего два пути:
1. Размножить исходный шейп в нескольких экземплярах (при этом форматирование сохранится). Потом вычеркивать из экземпляров лишние фрагменты, оставляя только нужный.
Например, такой код уберет все после восьмого символа, то есть оставит только первую строку
Код:
        ch.Begin = 8
        ch.End = 27
        ch.Text = ""

2. Создавать новые шейпы, копировать в них новые фрагменты текста. Потом отдельно поячеечно копировать форматирование из секции Characters.
Сдается мне, что первый вариант будет попроще. Особенно, если у Вас не только цвет меняется, но возможно вообще произвольное изменение формата. Опять же, если нужный фрагмент будет содержать несколько подстрок, отформатированных по-разному, то с первым способом будет проще управиться.
Цитата:
Как найти в нём строку по критерию?

Смотря что за критерий. Если под критерием понимается циферка, то нужно прочитать Shape.Text, а лучше Shape.Characters.Text и в этой строковой переменной искать совпадение кода символа с одним из 10 значений. Зная позиции цифр, разбивать строку на подстроки. Но если будете использовать первый способ, то и разбивать не надо, достаточно знать позиции.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 16:45 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
Tumanov писал(а):
Смотря что за критерий.
я пока экспериментировал на кошках, в качестве критерия взял перевод строки
Код:
Sub lulz()
Dim sc As Section, tt As String, txt As String
Dim wi As Single, he As Single, px As Single, py As Single
Dim sh As Shape, nsh As Shape, st As Integer, en As Integer
st = 1
Set sh = ActivePage.Shapes.ItemFromID(24) 'ActiveWindow.Selection.PrimaryItem
wi = sh.Cells("Width").Result(visInches)
he = sh.Cells("Height").Result(visInches)
px = sh.Cells("PinX").Result(visInches) + sh.Cells("LocPinX").Result(visInches)
py = sh.Cells("PinY").Result(visInches) + sh.Cells("LocPinY").Result(visInches)
tt = sh.Characters.Text
Set sc = sh.Section(visSectionCharacter)
For i = 1 To sc.Count
en = InStr(st, tt, Chr(10))
If en > 0 Then txt = Mid(tt, st, en - st + 1): st = en + 1
Set nsh = ActivePage.DrawRectangle(px + 1, py - he * (sc.Count - i) / (sc.Count), px + wi + 1, py - he * (sc.Count - i + 1) / (sc.Count))
nsh.Text = txt
Next
End Sub
делюсь здесь, чтоб не потерять. :D не смог добиться, чтоб новые раздельные фигуры рисовались сверху вниз :wall:

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 17:08 
Не в сети
Бывалый

Зарегистрирован: 25 янв 2017, 11:40
Сообщений: 126
Использую Visio c: 2013
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Surrogate писал(а):
я пока экспериментировал на кошках, в качестве критерия взял перевод строки
В качестве критериев я предполагал:
"Найти строки, которые кончаются на 1 или 2 или 3"

Результат согласно вашего кода - см. картинку.


Вложения:
2021-07-20_16-05-43.png
2021-07-20_16-05-43.png [ 6.72 Кб | Просмотров: 568 ]
Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 17:10 
Не в сети
Content manager
Content manager
Аватара пользователя

Зарегистрирован: 02 окт 2009, 01:01
Сообщений: 5043
Откуда: оттуда
Использую Visio c: 1998
Отрасль: Интеграция системных интеграторов
Должность: Дизайнер по оформлению документации
Уровнь квалификации: Форматирование документов MS Word
andr писал(а):
Результат согласно вашего кода
ну ладно, не нравится - не берите :mrgreen:

_________________
База знаний ShapeSheet
Мой Youtube-канал @surrogate-tm
Мои трафареты


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 21:08 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 2253
Очков репутации: 100626

Добавить очки репутацииУменьшить очки репутации
Ну вот, как-то так оно работает.
Код:
Sub ttt_1()
    Dim shp As Visio.Shape
    Dim ch As Visio.Characters
    Dim pCol As Collection
    Set pCol = New Collection
   
    Set shp = ActiveWindow.Selection(1)
    Set ch = shp.Characters
    s = ch.Text
    Debug.Print s
    n = ch.CharCount
    pCol.Add 1
    For i = 1 To n
        sn = Asc(Mid(s, i, 1))
        If sn > 47 And sn < 58 Then 'digit
            pCol.Add i
            Debug.Print i
        End If
    Next
    If n - pCol(pCol.Count) > 2 Then pCol.Add n
    For i = 1 To pCol.Count - 1
        Set sh1 = shp.Duplicate
        sh1.Cells("PinX") = shp.Cells("PinX") + shp.Cells("Width") + 0.1
        dy = shp.Cells("Height") / (pCol.Count - 1)
        sh1.Cells("Height") = dy
        sh1.Cells("PinY") = shp.Cells("PinY") + shp.Cells("Height") * 0.5 - dy * 0.5 - dy * (i - 1)
       
        Set ch = sh1.Characters
        If i = 1 Then
            ch.Begin = pCol(i + 1)
            ch.End = pCol(pCol.Count)
            ch.Text = ""
        Else
            ch.Begin = 0
            ch.End = pCol(i) + 1
            ch.Text = ""
            ch.Begin = pCol(i + 1) - pCol(i) - 1
            ch.End = pCol(pCol.Count)
            ch.Text = ""
        End If
    Next
   
End Sub

Нужно бы еще почистить на переводах строки, но это уже лень.


Вложения:
tsel_2.gif
tsel_2.gif [ 27.77 Кб | Просмотров: 464 ]
Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Разделить текст с сохранением форматирования
СообщениеДобавлено: 20 июл 2021, 22:42 
Не в сети
Бывалый

Зарегистрирован: 25 янв 2017, 11:40
Сообщений: 126
Использую Visio c: 2013
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Tumanov писал(а):
Ну вот, как-то так оно работает.
Код:
Sub ttt_1()
    Dim shp As Visio.Shape
    Dim ch As Visio.Characters
    Dim pCol As Collection
    Set pCol = New Collection
   
    Set shp = ActiveWindow.Selection(1)
    Set ch = shp.Characters
    s = ch.Text
    Debug.Print s
    n = ch.CharCount
    pCol.Add 1
    For i = 1 To n
        sn = Asc(Mid(s, i, 1))
        If sn > 47 And sn < 58 Then 'digit
            pCol.Add i
            Debug.Print i
        End If
    Next
    If n - pCol(pCol.Count) > 2 Then pCol.Add n
    For i = 1 To pCol.Count - 1
        Set sh1 = shp.Duplicate
        sh1.Cells("PinX") = shp.Cells("PinX") + shp.Cells("Width") + 0.1
        dy = shp.Cells("Height") / (pCol.Count - 1)
        sh1.Cells("Height") = dy
        sh1.Cells("PinY") = shp.Cells("PinY") + shp.Cells("Height") * 0.5 - dy * 0.5 - dy * (i - 1)
       
        Set ch = sh1.Characters
        If i = 1 Then
            ch.Begin = pCol(i + 1)
            ch.End = pCol(pCol.Count)
            ch.Text = ""
        Else
            ch.Begin = 0
            ch.End = pCol(i) + 1
            ch.Text = ""
            ch.Begin = pCol(i + 1) - pCol(i) - 1
            ch.End = pCol(pCol.Count)
            ch.Text = ""
        End If
    Next
   
End Sub

Нужно бы еще почистить на переводах строки, но это уже лень.

Не могли бы вы приложить файл...
У меня некорректно работает...
Требует прописать все переменные...
Я добавил...
Код:
Dim dy As Visio.Cell ' !!!!
Dim s As String ' !!!
Dim i As Integer ' !!!
Dim sn As String ' !!!


Всё равно, что-то не работает...

Код
Код:
Sub ttt_1()
    Dim shp As Visio.Shape
    Dim ch As Visio.Characters
    Dim pCol As Collection
    Set pCol = New Collection
   
    Set shp = ActiveWindow.Selection(1)
    Set ch = shp.Characters
   
    Dim s As String ' !!!
    s = ch.Text
    Debug.Print s
   
    Dim n As Integer
    n = ch.CharCount
    pCol.Add 1
   
    Dim i As Integer ' !!!
    For i = 1 To n
       
        Dim sn As String ' !!!
        sn = Asc(Mid(s, i, 1))
        If sn > 47 And sn < 58 Then 'digit
            pCol.Add i
            Debug.Print i
        End If
    Next
    If n - pCol(pCol.Count) > 2 Then pCol.Add n
    For i = 1 To pCol.Count - 1
        Dim sh1 As Shape
        Set sh1 = shp.Duplicate
        sh1.Cells("PinX") = shp.Cells("PinX") + shp.Cells("Width") + 0.1
       
        Dim dy As Visio.Cell ' !!!!
       
        dy = shp.Cells("Height") / (pCol.Count - 1)
       
        sh1.Cells("Height") = dy
        sh1.Cells("PinY") = shp.Cells("PinY") + shp.Cells("Height") * 0.5 - dy * 0.5 - dy * (i - 1)
       
        Set ch = sh1.Characters
       
        If i = 1 Then
            ch.Begin = pCol(i + 1)
            ch.End = pCol(pCol.Count)
            ch.Text = ""
        Else
            ch.Begin = 0
            ch.End = pCol(i) + 1
            ch.Text = ""
            ch.Begin = pCol(i + 1) - pCol(i) - 1
            ch.End = pCol(pCol.Count)
            ch.Text = ""
        End If
    Next
   
End Sub


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 24 ]  На страницу 1, 2  След.

Часовой пояс: UTC + 3 часа [ Летнее время ]



Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 10


Вы можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
Вы можете создать форум бесплатно PHPBB3 на Getbb.Ru, Также возможно сделать готовый форум PHPBB2 на Mybb2.ru
Русская поддержка phpBB