- Сообщения
- 2 156
- Реакции
- 2 081
Макрос работает только ничего не изменяет!Не помню точно, пишу с холодильника
ActiveDocument? ActiveLayer?
ТакиFor Each s In d.ActivePage.FindShapes(, cdrTextShape)
ActivePage
Sub TranslateText()ConvertRussianUnicode не работает?
Public Sub ConvertRussianUnicode()
' Description: Конвертирует ASCII текст в кириллицу UNICODE
'
Dim T As Text
Dim s As Shape
Dim d As Document
Dim i As Integer, N As Integer
Dim C As TextRange
Set d = ActiveDocument
'Устанавливаем начало группы для команды отмены
d.BeginCommandGroup "Convert Russian Text To Unicode"
'Перебираем все текстовые элементы текущей страницы
For Each s In d.ActivePage.FindShapes(, cdrTextShape)
For Each C In s.Text.Story.Characters
If C.CharSet <> cdrCharSetSymbol Then
N = AscW(C.WideText)
Select Case N
Case 165
C.WideText = ChrW$(1168): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ґ
Case 168
C.WideText = ChrW$(1025): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ё
Case 170
C.WideText = ChrW$(1028): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Є
Case 175
C.WideText = ChrW$(1031): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ї
Case 178
C.WideText = ChrW$(1030): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'І
Case 179
C.WideText = ChrW$(1110): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'і
Case 180
C.WideText = ChrW$(1169): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ґ
Case 184
C.WideText = ChrW$(1105): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ё
Case 186
C.WideText = ChrW$(1108): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'є
Case 191 To 255
C.WideText = ChrW$(N + 848): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'А-я
End Select
End If
Next C
Next s
d.EndCommandGroup
End Sub
Это работает! СПАСИБО!!!по ссылке @lev пример
Код:Public Sub ConvertRussianUnicode() ' Description: Конвертирует ASCII текст в кириллицу UNICODE ' Dim T As Text Dim s As Shape Dim d As Document Dim i As Integer, N As Integer Dim C As TextRange Set d = ActiveDocument 'Устанавливаем начало группы для команды отмены d.BeginCommandGroup "Convert Russian Text To Unicode" 'Перебираем все текстовые элементы текущей страницы For Each s In d.ActivePage.FindShapes(, cdrTextShape) For Each C In s.Text.Story.Characters If C.CharSet <> cdrCharSetSymbol Then N = AscW(C.WideText) Select Case N Case 165 C.WideText = ChrW$(1168): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ґ Case 168 C.WideText = ChrW$(1025): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ё Case 170 C.WideText = ChrW$(1028): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Є Case 175 C.WideText = ChrW$(1031): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ї Case 178 C.WideText = ChrW$(1030): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'І Case 179 C.WideText = ChrW$(1110): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'і Case 180 C.WideText = ChrW$(1169): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ґ Case 184 C.WideText = ChrW$(1105): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ё Case 186 C.WideText = ChrW$(1108): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'є Case 191 To 255 C.WideText = ChrW$(N + 848): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'А-я End Select End If Next C Next s d.EndCommandGroup End Sub
об этом @_MBK_ спрашивает
Подробностей бы поболее ... с файлом примеромЗависает
Извольте (кодировка почему-то китайскаяПодробностей бы поболее ... с файлом примером
неспешно, конечно .. но тот самый исходный код - работаетИзвольте
китайскаяизвраупрощённая)
Видимо, из-за большого количества таких объектов оно и виснет. Что ж, придётся вручную. Спасибо!неспешно, конечно .. но тот самый исходный код - работает
Посмотреть вложение 162447
ну и ... о
Посмотреть вложение 162448
и да - это всё в CorelDRAW 2018
сделаем чуть информативней и вариативнейиз-за большого количества таких объектов
Sub ConvertRussianUnicode()
' Description: Конвертирует ASCII текст в кириллицу UNICODE
Dim T As Text
Dim s As Shape
Dim d As Document
Dim i As Integer, N As Integer
Dim C As TextRange
Dim ASh, AShT
Set d = ActiveDocument
Optimization = True
EventsEnabled = False
ActiveDocument.SaveSettings
Set ASh = ActiveSelectionRange
If ASh.Count < 1 Then Set ASh = d.ActivePage
Set AShT = ASh.Shapes.FindShapes(Query:="@type = 'text:artistic' or @type = 'text:paragraph'")
MsgBox "Find " & AShT.Count & " text object" & vbNewLine & "I work carefully and not quickly, begin?"
CorelScriptTools.BeginWaitCursor
'Устанавливаем начало группы для команды отмены
d.BeginCommandGroup "Convert Russian Text To Unicode"
'Перебираем все текстовые элементы текущей страницы
For Each s In AShT
For Each C In s.Text.Story.Characters
If C.CharSet <> cdrCharSetSymbol Then
N = AscW(C.WideText)
Select Case N
Case 165
C.WideText = ChrW$(1168): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ґ
Case 168
C.WideText = ChrW$(1025): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ё
Case 170
C.WideText = ChrW$(1028): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Є
Case 175
C.WideText = ChrW$(1031): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ї
Case 178
C.WideText = ChrW$(1030): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'І
Case 179
C.WideText = ChrW$(1110): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'і
Case 180
C.WideText = ChrW$(1169): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ґ
Case 184
C.WideText = ChrW$(1105): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ё
Case 186
C.WideText = ChrW$(1108): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'є
Case 191 To 255
C.WideText = ChrW$(N + 848): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'А-я
End Select
End If
Next C
Next s
d.EndCommandGroup
CorelScriptTools.EndWaitCursor
MsgBox AShT.Count & " text object convert to UNICODE"
ActiveDocument.RestoreSettings
EventsEnabled = True
Optimization = False
ActiveWindow.Refresh
Application.Refresh
End Sub
Вот теперь сработало, спасибо!сделаем чуть информативней и вариативней
Добрый день.сделаем чуть информативней и вариативней
если что-то выделено - искать будет в выделенном
ничего не выделено - ищет по всей странице
скажет сколько нашёл
подождёт нажатия ОК
покажет красивый курсор
...
...
...
спрячет красивый курсор
выдаст отчёт
Код:Sub ConvertRussianUnicode() ' Description: Конвертирует ASCII текст в кириллицу UNICODE Dim T As Text Dim s As Shape Dim d As Document Dim i As Integer, N As Integer Dim C As TextRange Dim ASh, AShT Set d = ActiveDocument Optimization = True EventsEnabled = False ActiveDocument.SaveSettings Set ASh = ActiveSelectionRange If ASh.Count < 1 Then Set ASh = d.ActivePage Set AShT = ASh.Shapes.FindShapes(Query:="@type = 'text:artistic' or @type = 'text:paragraph'") MsgBox "Find " & AShT.Count & " text object" & vbNewLine & "I work carefully and not quickly, begin?" CorelScriptTools.BeginWaitCursor 'Устанавливаем начало группы для команды отмены d.BeginCommandGroup "Convert Russian Text To Unicode" 'Перебираем все текстовые элементы текущей страницы For Each s In AShT For Each C In s.Text.Story.Characters If C.CharSet <> cdrCharSetSymbol Then N = AscW(C.WideText) Select Case N Case 165 C.WideText = ChrW$(1168): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ґ Case 168 C.WideText = ChrW$(1025): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ё Case 170 C.WideText = ChrW$(1028): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Є Case 175 C.WideText = ChrW$(1031): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ї Case 178 C.WideText = ChrW$(1030): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'І Case 179 C.WideText = ChrW$(1110): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'і Case 180 C.WideText = ChrW$(1169): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ґ Case 184 C.WideText = ChrW$(1105): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ё Case 186 C.WideText = ChrW$(1108): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'є Case 191 To 255 C.WideText = ChrW$(N + 848): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'А-я End Select End If Next C Next s d.EndCommandGroup CorelScriptTools.EndWaitCursor MsgBox AShT.Count & " text object convert to UNICODE" ActiveDocument.RestoreSettings EventsEnabled = True Optimization = False ActiveWindow.Refresh Application.Refresh End Sub