[CDR X5-X8] Изменить кодировку текста

lev · 10.01.2018

Corel DRAW! VBA Scripts - 2004 г
На Вашем примере работает

_MBK_ · 10.01.2018

Не помню точно, пишу с холодильника
ActiveDocument? ActiveLayer? 'hmmm'

avniv · 10.01.2018

_MBK_ сказал(а):
Не помню точно, пишу с холодильника
ActiveDocument? ActiveLayer?

Макрос работает только ничего не изменяет!

_MBK_ · 10.01.2018

For Each s In d.ActivePage.FindShapes(, cdrTextShape)

Таки

avniv сказал(а):
ActivePage

_MBK_ · 10.01.2018

ConvertRussianUnicode не работает?

avniv · 10.01.2018

_MBK_ сказал(а):
ConvertRussianUnicode не работает?

Это что?

avniv · 10.01.2018

_MBK_ сказал(а):
ConvertRussianUnicode не работает?

Sub TranslateText()

Dim txts As ShapeRange
Dim sh As Shape
Set txts = ActivePage.FindShapes(Type:=cdrTextShape)
For Each sh In txts
'sh.Text.Story.LanguageID = 1033
'sh.Text.Story.CharSet = 0
' s = ""
' t = OrigSelection.Item(1).Text.Story.Text
' For I = 1 To Len(t)
' B = Mid(t, I, 1) + Chr(0)
' a = AscW(StrConv(B, vbFromUnicode))
' s = s + ChrB(a And 255) + ChrB(0)

' Next I
' sh.Text.Story.Text = s
sh.Text.Story.CharSet = cdrCharSetRussian
sh.Text.Story.LanguageID = cdrRussian

Next sh
End Sub
Так переделал, кодировку меняет, но корявые символы остаются. В ручную меняю все выходит. Почему?

dastin · 10.01.2018

по ссылке @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_ спрашивает

avniv · 10.01.2018

dastin сказал(а):

по ссылке @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_ спрашивает

Это работает! СПАСИБО!!!

Yar · 01.12.2023

Скажите, а может ли кто допилить этот макрос, чтобы работал в Corel 2018? Зависает

dastin · 01.12.2023

Yar сказал(а):
Зависает

Подробностей бы поболее ... с файлом примером

Yar · 01.12.2023

dastin сказал(а):
Подробностей бы поболее ... с файлом примером

Извольте (кодировка почему-то китайская ~~извра~~ упрощённая):

dastin · 01.12.2023

Yar сказал(а):
Извольте

неспешно, конечно .. но тот самый исходный код - работает

ну и ... о

Yar сказал(а):
китайская ~~извра~~ упрощённая)

и да - это всё в CorelDRAW 2018

Yar · 01.12.2023

dastin сказал(а):
неспешно, конечно .. но тот самый исходный код - работает
Посмотреть вложение 162447

ну и ... о

Посмотреть вложение 162448

и да - это всё в CorelDRAW 2018

Видимо, из-за большого количества таких объектов оно и виснет. Что ж, придётся вручную. Спасибо!

dastin · 01.12.2023

Yar сказал(а):
из-за большого количества таких объектов

сделаем чуть информативней и вариативней
если что-то выделено - искать будет в выделенном
ничего не выделено - ищет по всей странице
скажет сколько нашёл
подождёт нажатия ОК
покажет красивый курсор
...
...
...
спрячет красивый курсор
выдаст отчёт

Код:

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

Yar · 02.12.2023

dastin сказал(а):
сделаем чуть информативней и вариативней

Вот теперь сработало, спасибо!

Vikonter · 27.07.2024

dastin сказал(а):

сделаем чуть информативней и вариативней
если что-то выделено - искать будет в выделенном
ничего не выделено - ищет по всей странице
скажет сколько нашёл
подождёт нажатия ОК
покажет красивый курсор
...
...
...
спрячет красивый курсор
выдаст отчёт

Код:

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

Добрый день.
Спасибо. Использовал ваш модуль в решении задачи.
Возникли предложения/вопросы по дополнению:
- сделать возможной конвертацию на нескольких страницах
- возможность переводить из 1252 (ANSI латиница) в 1251 (ANSI кириллица
Прошу, по возможности, дописать дополнения.

Поиск

[CDR X5-X8] Изменить кодировку текста

lev

Модератор

_MBK_

Пикирующий бомбардировщик

avniv

_MBK_

Пикирующий бомбардировщик

_MBK_

Пикирующий бомбардировщик

avniv

avniv

dastin

Некромант-любитель

avniv

Yar

dastin

Некромант-любитель

Yar

Вложения

dastin

Некромант-любитель

Yar

dastin

Некромант-любитель

Yar

Vikonter

Участник