[CDR 2017-2021] Как разбить текст на отдельные буквы?

[Karatau]

Здравствуйте, коллеги.
Подскажите, каким образом при помощи макроса можно разбить Фигурный текст на отдельные символы? И было бы замечательно, если бы они все входили в один ShapeRange.

Поделитесь знаниями?

И еще про пробелы: они, насколько я понял, должны все исчезнуть, останутся только раздельные буквы и символы

 

[_MBK_]

А зачем при помощи макроса? Чем стандартный Ctrl-K не нравится?

 

[lev]

Не помню как в остальных версиях, но в X7 после BreakApart остаётся выделенным только первый элемент, соответственно надо перевыделять остатки и делать на каждый свой BreakApart.
Например, следующий код возьмет все текстовки на странице и побъёт по буквам (без ползаний по клипам и т.п.) - делается двойной BreakApart всех текстовок на странице.

Sub baa()
  ActiveDocument.BeginCommandGroup ("Break Apart Text")
  For Each s In ActivePage.Shapes.FindShapes(, cdrTextShape)
    s.BreakApart
  Next s
  For Each s In ActivePage.Shapes.FindShapes(, cdrTextShape)
    s.BreakApart
  Next s
  ActiveDocument.EndCommandGroup
End Sub

А следующий код, должен был бы выдать на выходе ShapeRange sr2 с набором буковок, но из-за бага с BreakApart, перешедшим и в VBA, в Range попадает только первый элемент разбитого текста, и надо делать всякие мудрёности по перевылавливанию, которые лично мне делать лень.

Sub ba()
  ActiveDocument.BeginCommandGroup ("Break Apart Text Bug")
  Dim sr As New ShapeRange, sr2 As New ShapeRange, s As Shape
  For Each s In ActivePage.Shapes.FindShapes(, cdrTextShape) 'ActiveSelection.Shapes.FindShapes(, cdrTextShape)
    sr.AddRange s.BreakApartEx
  Next s
  For Each s In sr
    sr2.AddRange s.BreakApartEx
  Next s
  sr2.AddToSelection
  ActiveDocument.EndCommandGroup
End Sub

 

[_MBK_]

но в X7 после BreakApart остаётся выделенным только первый элемент

В предыдущих тоже

 

[Karatau]

А зачем при помощи макроса? Чем стандартный Ctrl-K не нравится?

Дальше с каждой буквой будет проводится другая операция, типа описать квадрат определенного размера в центре с этой буквой и экспортнуть в PLT. А дальше на станок.

 

[dastin]

Подскажите, каким образом при помощи макроса можно разбить Фигурный текст на отдельные символы?

один ShapeRange - выделенное перемещать на новый слой
из этой темы макрос
разделит насколько вам захочется
дальше выделить всё на новом слое
?

 

[Karatau]

Не помню как в остальных версиях, но в X7 после BreakApart остаётся выделенным только первый элемент, соответственно надо перевыделять остатки и делать на кждый свой BreakApart.
Например, следующий код возьмет все текстовки на странице и побъёт по буквам (без ползаний по клипам и т.п.) - делается двойной BreakApart всех текстовок на странице.

Сегодня целый день экспериментировал с BreakApart и с BreakApartEx и тоже понял, что одной процедурой это не сделать. И двумя тоже, если текст в несколько строк. Да и собрать буквы в один Range затруднительно...

 

[Karatau]

один ShapeRange - выделенное перемещать на новый слой
из этой темы макрос
разделит насколько вам захочется
дальше выделить всё на новом слое
?

Спасибо! Но хотелось бы все это отдельной процедурой в макросе написать, чтобы можно было работать дальше с каждой буквой

 

[Karatau]

Возникла мысль такая. Возможно же вычислить координаты каждой буквы? Находим координаты последней буквы, они совпадают с правыми координатами текстового объекта. Убираем последнюю букву и опять находим координаты уже предпоследней буквы. И так по всем буквам, главное, чтобы у текста было левое выравнивание. А потом есть координаты и есть свойства текста, можно воссоздать каждую букву отдельно. Или это геморрой?... )))

 

[dastin]

код открыт ... а вы, насколько помнится, не чужды . возьмите оттуда только нужное - разбить на символы
выделить, переместить на новый слой с именем Х, разбить на символы, выделить всё на этом новом слое - вот вам ShapeRange - дальше перебором каждый символ обрабатывайте как вы планируете ... нет?

 

[DukereD]

Решил и я подобную задачку реализовать.
В принципе получилось
Суть такая.
прежде чем разобрать текст мы его помечаем

s.Name = "text_to_brake"

а далее выбираем запросом

ActivePage.Shapes.FindShapes(Query:="@name= 'text_to_brake'")

ну и когда уже делаем разъединение, то текст разваливается и у каждого кусочка остаётся такое же имя.
снова ищем. и снова разламываем до тех пор пока длинна символа не будет равна 1

З.Ы. Кто подскажет в какой еще параметр кроме Name можно что-то записать служебное пометить так сказать ?

 

[lev]

Очередная вариация, с очередными багами
Отлавливаем сразу текстовки с количеством символов > 0, и пока такие существуют разбиваем их по символам
и тут мы втыкаемся в бесконечный цикл - оказывается Корел разбивая посимвольно оставляет в живых пробелы прилепленные к буквам. Мы можем поудалять пробелы до разбития, но тогда у нас сползут тексты с ведущими пробелами. Поэтому оставляем в живых левые пробелы, правые удаляем (необязательно) и втыкаем счётчик на кол-во разбиений, чтобы не было бесконечного цикла (имхо трёх итераций должно быть достаточно, я сделал на одну больше). Ещё одна необязательная операция - переводим параграфтексты в артистики. Если хотим разбивать только выделенный текст, то можно программно поименовать его, как в предыдущем посте от @DukereD и отлавливать, немного изменив строку запроса.

Sub bta()
  Dim s As Shape, i!

  ActiveDocument.BeginCommandGroup "Break texts apart"

  While (ActivePage.Shapes.FindShapes(, cdrTextShape, , "@com.Text.Story.Characters.Count>1").Count > 0) And i < 4
    For Each s In ActivePage.Shapes.FindShapes(, cdrTextShape, , "@com.Text.Story.Characters.Count>1")
      s.Text.Story = RTrim(s.Text.Story)
      s.BreakApart
      i = i + 1
    Next s
  Wend

  For Each s In ActivePage.Shapes.FindShapes(, cdrTextShape, , "@com.Text.Type = 1")
    s.Text.ConvertToArtistic
  Next s

  ActiveDocument.EndCommandGroup
End Sub

 

[DukereD]

Очередная вариация, с очередными багами
Отлавливаем сразу текстовки с количеством символов > 0, и пока такие существуют разбиваем их по символам
и тут мы втыкаемся в бесконечный цикл - оказывается Корел разбивая посимвольно оставляет в живых пробелы прилепленные к буквам. Мы можем поудалять пробелы до разбития, но тогда у нас сползут тексты с ведущими пробелами. Поэтому оставляем в живых левые пробелы, правые удаляем (необязательно) и втыкаем счётчик на кол-во разбиений, чтобы не было бесконечного цикла (имхо трёх итераций должно быть достаточно, я сделал на одну больше). Ещё одна необязательная операция - переводим параграфтексты в артистики. Если хотим разбивать только выделенный текст, то можно программно поименовать его, как в предыдущем посте от @DukereD и отлавливать, немного изменив строку запроса.

ваш код тоже рабочий. но и мой вполне себе справляется.
А я лишь написал суть того как отловить отвалившийся кусок текста (пометив его).

как вы можете судить о моей реализации не видя полный код? никакиг багов и зацикливаний. может не столь изящный. но и без лишних запросов FindShapes

 

[lev]

Вам показалось. Я не судил о Вашей реализации, я относил это с своему тексту ниже. Извиняюсь за недопонимание.
Я писал о багах в кореловской модели - 1) оставление пробелов при разбиении по буквам, что ведёт к зацикливанию в моей реализации, и 2) о скачке теста в сторону при избавлении от ведущих пробелов - это как бы не баг, но тоже неприятно.

в какой еще параметр кроме Name можно что-то записать служебное пометить так сказать ?

Можете попробовать использовать методы shape.Properties или shape.ObjectData

 

[DukereD]

Можете попробовать использовать методы shape.Properties или shape.ObjectData

Спасибо! Прошу прощения тоже видимо не так понял )

вот моя полная функция на кнопку "разломать"

Private Sub btn_break_all_Click()
    If Not inset Then Doc.BeginCommandGroup "Break all"
    Set OS = ActiveSelectionRange.UngroupAllEx.Shapes '(1).BreakApartEx
    For Each s In OS
        If s.DisplayCurve Is Nothing And s.Type = cdrTextShape Then
            s.Name = "text_to_brake"
            fnd_all = False
            Do
            Set sr = ActivePage.Shapes.FindShapes(Query:="@name= 'text_to_brake'")
            For Each t In sr
                fnd_all = True
                If InStr(1, Trim(t.Text.Story.Text), " ") > 0 Then
                    t.BreakApartEx
                    fnd_all = False
                ElseIf Len(Trim(t.Text.Story.Text)) > 1 Then
                    t.BreakApartEx
                End If
            Next t
            Loop While Not fnd_all
            Set sr = ActivePage.Shapes.FindShapes(Query:="@name= 'text_to_brake'")
            For Each t In sr
                t.Name = ""
            Next t
            sr.CreateSelection
        Else
            If s.DisplayCurve.SubPaths.Count > 1 Then
                Set br = s.BreakApartEx
            Else
        End If
        End If
    Next s
    If Not inset Then Doc.EndCommandGroup
End Sub