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

lev

Модератор
20 лет на форуме
Сообщения
2 142
Реакции
2 066
  • Спасибо
Реакции: dastin

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Не помню точно, пишу с холодильника
ActiveDocument? ActiveLayer? 'hmmm'
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
ConvertRussianUnicode не работает?
 

avniv

Топикстартер
15 лет на форуме
Сообщения
131
Реакции
1
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

Некромант-любитель
12 лет на форуме
Сообщения
2 131
Реакции
2 027
по ссылке @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

avniv

Топикстартер
15 лет на форуме
Сообщения
131
Реакции
1
по ссылке @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

15 лет на форуме
Сообщения
518
Реакции
156
Скажите, а может ли кто допилить этот макрос, чтобы работал в Corel 2018? Зависает
 

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 131
Реакции
2 027
  • Спасибо
Реакции: Yar

Yar

15 лет на форуме
Сообщения
518
Реакции
156

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 131
Реакции
2 027
из-за большого количества таких объектов
сделаем чуть информативней и вариативней
если что-то выделено - искать будет в выделенном
ничего не выделено - ищет по всей странице
скажет сколько нашёл
подождёт нажатия ОК
покажет красивый курсор
...
...
...
спрячет красивый курсор
выдаст отчёт
Код:
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