Corel Draw macros _ curve all text
UPD:
Изменения!!!
________________
Option Explicit
Sub Alltext_to_curve_Svoe()
Dim pageIndex As Long
Dim j As Long
Dim textList As Collection
Dim s As Shape
Dim foundCount As Long
Dim convertedCount As Long
Dim weldCount As Long
Dim failedCount As Long
Dim pageFound As Long
Dim pageConverted As Long
Dim pageWeld As Long
Dim pageFailed As Long
Dim report As String
Dim errorText As String
Dim commandStarted As Boolean
On Error GoTo ErrorHandler
ActiveDocument.BeginCommandGroup "All Text to Curves + Weld"
commandStarted = True
' ==========================================
' 1. Обрабатываем обычные страницы по очереди
' ==========================================
For pageIndex = 1 To ActiveDocument.Pages.Count
Set textList = New Collection
pageFound = 0
pageConverted = 0
pageWeld = 0
pageFailed = 0
' Собираем текст только текущей страницы
CollectPageText ActiveDocument.Pages(pageIndex).shapes, textList
pageFound = textList.Count
foundCount = foundCount + pageFound
' Обрабатываем найденный текст в обратном порядке
For j = textList.Count To 1 Step -1
Set s = textList(j)
If ConvertAndWeldOne( _
s, pageWeld) Then
pageConverted = pageConverted + 1
Else
pageFailed = pageFailed + 1
End If
Next j
convertedCount = convertedCount + pageConverted
weldCount = weldCount + pageWeld
failedCount = failedCount + pageFailed
report = report & _
"Страница " & pageIndex & vbCrLf & _
" Найдено текстовых объектов: " & pageFound & vbCrLf & _
" Преобразовано: " & pageConverted & vbCrLf & _
" Операций Weld: " & pageWeld & vbCrLf & _
" Ошибок: " & pageFailed & vbCrLf & vbCrLf
Next pageIndex
' ==========================================
' 2. Обрабатываем мастер-страницу
' ==========================================
Set textList = New Collection
pageFound = 0
pageConverted = 0
pageWeld = 0
pageFailed = 0
CollectPageText ActiveDocument.MasterPage.shapes, textList
pageFound = textList.Count
foundCount = foundCount + pageFound
For j = textList.Count To 1 Step -1
Set s = textList(j)
If ConvertAndWeldOne( _
s, pageWeld) Then
pageConverted = pageConverted + 1
Else
pageFailed = pageFailed + 1
End If
Next j
convertedCount = convertedCount + pageConverted
weldCount = weldCount + pageWeld
failedCount = failedCount + pageFailed
report = report & _
"Мастер-страница" & vbCrLf & _
" Найдено текстовых объектов: " & pageFound & vbCrLf & _
" Преобразовано: " & pageConverted & vbCrLf & _
" Операций Weld: " & pageWeld & vbCrLf & _
" Ошибок: " & pageFailed & vbCrLf & vbCrLf
' ==========================================
' 3. Завершение
' ==========================================
ActiveDocument.ClearSelection
ActiveDocument.EndCommandGroup
commandStarted = False
MsgBox _
"Обработка завершена!" & vbCrLf & vbCrLf & _
"Найдено текстовых объектов: " & foundCount & vbCrLf & _
"Преобразовано в кривые: " & convertedCount & vbCrLf & _
"Операций Weld: " & weldCount & vbCrLf & _
"Ошибок обработки: " & failedCount & vbCrLf & vbCrLf & _
report, _
vbInformation, "Alltext_to_curve_Svoe"
Exit Sub
ErrorHandler:
errorText = Err.Description
On Error Resume Next
ActiveDocument.ClearSelection
If commandStarted Then
ActiveDocument.EndCommandGroup
End If
On Error GoTo 0
MsgBox _
"Ошибка при обработке документа." & vbCrLf & _
"Страница: " & pageIndex & vbCrLf & _
errorText & vbCrLf & vbCrLf & _
"Найдено: " & foundCount & vbCrLf & _
"Преобразовано: " & convertedCount & vbCrLf & _
"Операций Weld: " & weldCount & vbCrLf & _
"Ошибок отдельных объектов: " & failedCount, _
vbExclamation, "Alltext_to_curve_Svoe"
End Sub
' ==================================================
' Рекурсивный поиск текста в группах и PowerClip
' ==================================================
Private Sub CollectPageText( _
ByVal shapes As shapes, _
ByRef textList As Collection)
Dim s As Shape
Dim pwc As PowerClip
On Error GoTo ExitHere
For Each s In shapes
If s.Type = cdrTextShape Then
textList.Add s
Else
' Поиск внутри групп
If s.Type = cdrGroupShape Then
CollectPageText s.shapes, textList
End If
' Поиск внутри PowerClip
Set pwc = Nothing
On Error Resume Next
Set pwc = s.PowerClip
On Error GoTo ExitHere
If Not pwc Is Nothing Then
CollectPageText pwc.shapes, textList
End If
End If
Next s
ExitHere:
End Sub
' ==================================================
' Преобразование текста и Weld
' Возвращает True, если ConvertToCurves выполнен
' без ошибки.
' ==================================================
Private Function ConvertAndWeldOne( _
ByVal txt As Shape, _
ByRef weldCount As Long) As Boolean
Dim sr As ShapeRange
Dim groupShape As Shape
Dim child As Shape
Dim children As ShapeRange
Dim i As Long
On Error GoTo ItemError
ConvertAndWeldOne = False
' Выбираем текст и преобразуем в кривые
txt.CreateSelection
ActiveSelectionRange.ConvertToCurves
Set sr = ActiveSelectionRange
If sr.Count = 0 Then GoTo ItemError
' ==========================================
' Результат — одна группа
' ==========================================
If sr.Count = 1 Then
Set groupShape = sr(1)
If groupShape.Type = cdrGroupShape Then
Set children = groupShape.shapes.All
For i = 1 To children.Count
Set child = children(i)
If child.Type <> cdrGroupShape Then
child.CreateSelection
If ActiveSelectionRange.Count > 0 Then
ActiveSelectionRange(1).Weld _
ActiveSelectionRange(1), False, False
weldCount = weldCount + 1
End If
End If
Next i
Else
groupShape.CreateSelection
If ActiveSelectionRange.Count > 0 Then
ActiveSelectionRange(1).Weld _
ActiveSelectionRange(1), False, False
weldCount = weldCount + 1
End If
End If
Else
' ==========================================
' Несколько объектов после преобразования
' ==========================================
For i = 1 To sr.Count
Set child = sr(i)
If child.Type <> cdrGroupShape Then
child.CreateSelection
If ActiveSelectionRange.Count > 0 Then
ActiveSelectionRange(1).Weld _
ActiveSelectionRange(1), False, False
weldCount = weldCount + 1
End If
End If
Next i
End If
ConvertAndWeldOne = True
Exit Function
ItemError:
ConvertAndWeldOne = False
End Function
Скрипт (макрос) кривит текст в документе, также убирает пересечение контуров на Google шрифтах (или других подобных). Заметил проблемму в таких шрифтах пересечение контура. Макрос велдит объект после кривления шрифта, что позволяет избавляться от артефактов.
Option Explicit
Sub Alltext_to_curve()
Dim i As Long
Dim j As Long
Dim s As Shape
Dim textList As New Collection
Dim processed As Long
On Error GoTo ErrorHandler
ActiveDocument.BeginCommandGroup "All Text to Curves + Weld"
' ==========================================
' 1. Собираем текст со всех обычных страниц
' ==========================================
For i = 1 To ActiveDocument.Pages.Count
CollectTextRecursive ActiveDocument.Pages(i).Shapes, textList
Next i
' ==========================================
' 2. Собираем текст мастер-страницы
' ==========================================
CollectTextRecursive ActiveDocument.MasterPage.Shapes, textList
' ==========================================
' 3. Обрабатываем собранный текст
' ==========================================
For j = 1 To textList.Count
Set s = textList(j)
ConvertAndWeldText s, processed
Next j
ActiveDocument.ClearSelection
ActiveDocument.EndCommandGroup
MsgBox "Готово!" & vbCrLf & _
"Обработано объектов: " & processed, _
vbInformation, "Alltext_to_curve"
Exit Sub
ErrorHandler:
Dim errorText As String
errorText = Err.Description
On Error Resume Next
ActiveDocument.ClearSelection
ActiveDocument.EndCommandGroup
On Error GoTo 0
MsgBox "Ошибка: " & errorText & vbCrLf & _
"Обработано объектов: " & processed, _
vbExclamation, "Alltext_to_curve"
End Sub
' ==================================================
' Рекурсивный поиск текста внутри групп и PowerClip
' ==================================================
Private Sub CollectTextRecursive( _
ByVal shapes As Shapes, _
ByRef textList As Collection)
Dim s As Shape
Dim pwc As PowerClip
On Error GoTo ExitHere
For Each s In shapes
' Если это текст — добавляем в список
If s.Type = cdrTextShape Then
textList.Add s
Else
' Если это группа — обходим её содержимое
If s.Type = cdrGroupShape Then
CollectTextRecursive s.Shapes, textList
End If
' Если это PowerClip — обходим его содержимое
Set pwc = Nothing
On Error Resume Next
Set pwc = s.PowerClip
On Error GoTo ExitHere
If Not pwc Is Nothing Then
CollectTextRecursive pwc.Shapes, textList
End If
End If
Next s
ExitHere:
End Sub
' ==================================================
' Преобразование текста в кривые и Weld
' ==================================================
Private Sub ConvertAndWeldText( _
ByVal txt As Shape, _
ByRef processed As Long)
Dim sr As ShapeRange
Dim groupShape As Shape
Dim child As Shape
Dim children As ShapeRange
Dim i As Long
' Преобразуем исходный текст в кривые
txt.CreateSelection
ActiveSelectionRange.ConvertToCurves
Set sr = ActiveSelectionRange
If sr.Count = 0 Then Exit Sub
' ==========================================
' Результат — одна группа
' ==========================================
If sr.Count = 1 Then
Set groupShape = sr(1)
If groupShape.Type = cdrGroupShape Then
Set children = groupShape.Shapes.All
For i = 1 To children.Count
Set child = children(i)
If child.Type <> cdrGroupShape Then
' Проверенный способ: выделяем ребёнка
' и вызываем Weld через выделение
child.CreateSelection
If ActiveSelectionRange.Count > 0 Then
ActiveSelectionRange(1).Weld _
ActiveSelectionRange(1), False, False
processed = processed + 1
End If
End If
Next i
Else
' Одиночный объект
groupShape.CreateSelection
If ActiveSelectionRange.Count > 0 Then
ActiveSelectionRange(1).Weld _
ActiveSelectionRange(1), False, False
processed = processed + 1
End If
End If
Else
' ==========================================
' Несколько объектов в выделении
' ==========================================
For i = 1 To sr.Count
Set child = sr(i)
If child.Type <> cdrGroupShape Then
child.CreateSelection
If ActiveSelectionRange.Count > 0 Then
ActiveSelectionRange(1).Weld _
ActiveSelectionRange(1), False, False
processed = processed + 1
End If
End If
Next i
End If
End Sub
что-то на новопидорском