[CDR 2017-2022] Количество слов

pivovodka · Пятница в 14:09

Подскажите, существует ли макрос или ещё что для отображения количества одинаковых слов?
Например у меня много слов "BTHL" на листе, родной инструмент "Поиск и замена текста" не выдает количество.
Было бы здорово что-то вроде кнопки "найти всё" или после нажатия "заменить всё" отобразить кол-во замен, как в Word.
Заранее спасибо!

zollinger · Пятница в 14:13

киньте пример файла

pivovodka · Пятница в 14:30

zollinger сказал(а):
киньте пример файла

Можно просто написать на чистом листе любое слово и скопипастить его...

~RA~ · Пятница в 15:15

Я не знаю как там в кореле, но в конкурсе на самое извращённое решение я бы участвовал с примерно таким способом:
soffice --convert-to svg BTHL.cdr && grep -io BTHL BTHL.svg | wc -l

DukereD · Пятница в 15:48

ну раз тут все извращенцы, то предложу еще один способ.
макросом- нумератором заменить слово - самая большая цифра и будет количество )

mnemonix · Пятница в 15:55

zollinger · Пятница в 16:04

zollinger · Пятница в 16:08

NNN5 · Пятница в 16:11

Сделайте поиск-замену на то же самое слово. Выделив все объекты на странице. Получите количество

lev · Пятница в 16:26

Думаю "BHTL" и "bhtl" должны отличаться (в вашем примере их нет)
"нет" и "нет," возможно, должны быть одинаковыми и считаться вместе

zollinger · Пятница в 16:37

Да, поэтому и нужен был пример "боевого" файла, а не брошенный как кость расставленные 4 артистик текста. Будет ли этот текст в разных регистрах (и считать ли их разными словами), будет ли текст состоять только из искомого слова, будут ли там параграф тексты или только артистики...

Chiga · Пятница в 16:45

zollinger сказал(а):
Посмотреть вложение 175831

Отсортируй по количеству, потом по алфавиту, выглядит некрасиво.

zollinger · Пятница в 16:48

Chiga сказал(а):
Отсортируй по количеству, потом по алфавиту, выглядит некрасиво.

Жить нужно не для радости, а для совести!

Зачем мне это?

zollinger · Пятница в 16:55

Хотя че уж там... Только из уважения к @Chiga

Код с оформлением (BB-коды):

Sub CountWordsSorted()
    Dim doc As Document
    Dim s As Shape
    Dim allText As String
    Dim words() As String
    Dim wordCount As Object
    Dim w As Variant
    Dim trimmedWord As String
    Dim cleanedText As String
    Dim result As String
    Dim keyArray As Variant
    Dim i As Long
   
    Set doc = ActiveDocument
    Set wordCount = CreateObject("Scripting.Dictionary")
   
    For Each s In doc.ActivePage.Shapes
        If s.Type = cdrTextShape Then
            cleanedText = s.Text.Story.Text
            cleanedText = RemoveSpecialChars(cleanedText)
            cleanedText = Trim(cleanedText)
            allText = allText & " " & cleanedText
        End If
    Next s
   
    words = Split(LCase(allText))
   
    For Each w In words
        trimmedWord = Trim(w)
        If Len(trimmedWord) > 0 Then
            If wordCount.Exists(trimmedWord) Then
                wordCount(trimmedWord) = wordCount(trimmedWord) + 1
            Else
                wordCount.Add trimmedWord, 1
            End If
        End If
    Next w
   
    keyArray = wordCount.Keys
    Call QuickSortStrings(keyArray, LBound(keyArray), UBound(keyArray))
   
    result = "Количество одинаковых слов:" & vbCrLf
    For i = LBound(keyArray) To UBound(keyArray)
        result = result & keyArray(i) & ": " & wordCount(keyArray(i)) & vbCrLf
    Next i
   
    MsgBox result, vbInformation, "Результат подсчёта"
End Sub

Function RemoveSpecialChars(str As String) As String
    Dim i As Integer
    Dim ch As String
    Dim resultStr As String
    resultStr = ""
   
    For i = 1 To Len(str)
        ch = Mid(str, i, 1)
        If Asc(ch) >= 32 Then
            resultStr = resultStr & ch
        Else
            resultStr = resultStr & " "
        End If
    Next i
   
    RemoveSpecialChars = resultStr
End Function

Sub QuickSortStrings(arr As Variant, first As Long, last As Long)
    Dim pivot As String
    Dim i As Long, j As Long
    Dim temp As String
   
    If first >= last Then Exit Sub
   
    pivot = arr((first + last) \ 2)
    i = first
    j = last
   
    Do While i <= j
        Do While StrComp(arr(i), pivot, vbTextCompare) < 0
            i = i + 1
        Loop
        Do While StrComp(arr(j), pivot, vbTextCompare) > 0
            j = j - 1
        Loop
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Loop
   
    If first < j Then QuickSortStrings arr, first, j
    If i < last Then QuickSortStrings arr, i, last
End Sub

~RA~ · Пятница в 17:25

Ошибка.
Правильно "Славься, Рома!" и "Мама мыла раму".

zollinger · Пятница в 17:25

И отсортировано по алфавиту, и знаки препинания учитывает...

Код:

Sub CountWordsSorted()
    Dim doc As Document
    Dim s As Shape
    Dim allText As String
    Dim words() As String
    Dim wordCount As Object
    Dim w As Variant
    Dim trimmedWord As String
    Dim cleanedText As String
    Dim result As String
    Dim keyArray As Variant
    Dim i As Long
    
    Set doc = ActiveDocument
    Set wordCount = CreateObject("Scripting.Dictionary")
    
    ' Проходим по всем текстовым объектам на странице
    For Each s In doc.ActivePage.Shapes
        If s.Type = cdrTextShape Then
            cleanedText = s.Text.Story.Text
            cleanedText = RemoveSpecialChars(cleanedText) ' Удаляем спецсимволы 1-31
            cleanedText = RemovePunctuation(cleanedText)  ' Удаляем знаки препинания
            cleanedText = Trim(cleanedText)               ' Убираем пробелы в начале и конце
            allText = allText & " " & cleanedText
        End If
    Next s
    
    ' Разбиваем весь текст на слова
    words = Split(LCase(allText))
    
    ' Считаем количество каждого слова в словаре
    For Each w In words
        trimmedWord = Trim(w)
        If Len(trimmedWord) > 0 Then
            If wordCount.Exists(trimmedWord) Then
                wordCount(trimmedWord) = wordCount(trimmedWord) + 1
            Else
                wordCount.Add trimmedWord, 1
            End If
        End If
    Next w
    
    ' Получаем массив ключей (слов) из словаря
    keyArray = wordCount.Keys
    
    ' Сортируем массив по алфавиту
    Call QuickSortStrings(keyArray, LBound(keyArray), UBound(keyArray))
    
    ' Формируем строку результата для вывода
    result = "Количество одинаковых слов:" & vbCrLf & "(в алфавитном порядке) " & vbCrLf & vbCrLf
    For i = LBound(keyArray) To UBound(keyArray)
        result = result & keyArray(i) & ": " & wordCount(keyArray(i)) & vbCrLf
    Next i
    
    ' Выводим сообщение
    MsgBox result, vbInformation, "Результат подсчёта"
End Sub

' Удаление спецсимволов с кодами от 1 до 31 включительно, заменяем на пробел
Function RemoveSpecialChars(str As String) As String
    Dim i As Integer
    Dim ch As String
    Dim resultStr As String
    resultStr = ""
    
    For i = 1 To Len(str)
        ch = Mid(str, i, 1)
        If Asc(ch) >= 32 Then
            resultStr = resultStr & ch
        Else
            resultStr = resultStr & " "
        End If
    Next i
    
    RemoveSpecialChars = resultStr
End Function

' Удаление всех знаков препинания, сохранение кириллицы, латиницы, цифр и пробелов
Function RemovePunctuation(text As String) As String
    Dim i As Long
    Dim ch As String
    Dim code As Integer
    Dim resultStr As String
    resultStr = ""
    
    For i = 1 To Len(text)
        ch = Mid(text, i, 1)
        code = AscW(ch)
        
        ' Латиница A-Z a-z
        If (code >= 65 And code <= 90) Or (code >= 97 And code <= 122) Then
            resultStr = resultStr & ch
        ' Кириллица А-Я, а-я, Ё, ё
        ElseIf (code >= 1040 And code <= 1103) Or code = 1025 Or code = 1105 Then
            resultStr = resultStr & ch
        ' Цифры 0-9
        ElseIf (code >= 48 And code <= 57) Then
            resultStr = resultStr & ch
        ' Пробел
        ElseIf ch = " " Then
            resultStr = resultStr & ch
        Else
            ' Удаляем остальные символы (знаки препинания)
            resultStr = resultStr & " "
        End If
    Next i
    
    RemovePunctuation = resultStr
End Function

' Быстрая сортировка массива строк (алфавитно, без учёта регистра)
Sub QuickSortStrings(arr As Variant, first As Long, last As Long)
    Dim pivot As String
    Dim i As Long, j As Long
    Dim temp As String
    
    If first >= last Then Exit Sub
    
    pivot = arr((first + last) \ 2)
    i = first
    j = last
    
    Do While i <= j
        Do While StrComp(arr(i), pivot, vbTextCompare) < 0
            i = i + 1
        Loop
        Do While StrComp(arr(j), pivot, vbTextCompare) > 0
            j = j - 1
        Loop
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Loop
    
    If first < j Then QuickSortStrings arr, first, j
    If i < last Then QuickSortStrings arr, i, last
End Sub

zollinger · Пятница в 17:26

~RA~ сказал(а):
Ошибка.
Правильно "Славься, Рома!" и "Мама мыла раму".

Ай-яй-яй, и кто же это сделал?

Chiga · Пятница в 17:28

zollinger сказал(а):
Посмотреть вложение 175835

Но сортирует только по алфавиту 'fp'

zollinger · Пятница в 17:30

Chiga сказал(а):
Но сортирует только по алфавиту

А куда его втыкать, столько текста? в маленькое окно месседжа? Главное, неизвестно, нужно ли оно вообще кому-нибудь. Тут вот я с Ромой согласен, кому оно нужно?

Chiga · Пятница в 17:40

zollinger сказал(а):
кому оно нужно?

ТСу нужно, в первом посте нормально хотелка написана, это уже мы отсебятину начали городить.

Поиск

[CDR 2017-2022] Количество слов

pivovodka

Участник

zollinger

Не человек. Золото

pivovodka

Участник

Вложения

~RA~

🄯

DukereD

макрософил

mnemonix

ॐ मणि पद्मे हूँ

zollinger

Не человек. Золото

zollinger

Не человек. Золото

NNN5

Модератор

lev

Модератор

zollinger

Не человек. Золото

Chiga

zollinger

Не человек. Золото

zollinger

Не человек. Золото

~RA~

🄯

zollinger

Не человек. Золото

zollinger

Не человек. Золото

Chiga

zollinger

Не человек. Золото

Chiga