Alex_Gur (Все сообщения пользователя)

Как убрать ударение макросом? VBA

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

06.11.2023 10:56:36

Вот еще макрос, позволяющий удалить ударения из выделенного фрагмента в Ворде.
Этот макрос можно использовать также в случае, когда текст слишком большой. Можно будет выделать отдельные фрагменты текста и удалять ударения в этих фрагментах.

Код

Sub Udalenie_Udarenij_In_Selection1()
'Удаление ударений из выделенного фрагмента
'Предварительно нужно выделить фрагмент, в котором будет выполняться удаление ударений

    Dim rng As Range
    Set rng = Selection.Range

     'перебор всех символов
     Dim Chr As Object
     For Each Chr In rng.Characters
        With Chr
            'Всего гласных букв в русском языке насчитывается 10:
            'а, е, ё, и, о, у, ы, э, ю, я.

            Select Case Chr
                Case "а" & ChrW(769)
                    Chr = "а"
                Case "е" & ChrW(769)
                    Chr = "е"
                Case "ё" & ChrW(769)
                    Chr = "ё"
                Case "и" & ChrW(769)
                    Chr = "и"
                Case "о" & ChrW(769)
                    Chr = "о"
                Case "у" & ChrW(769)
                    Chr = "у"
                Case "ы" & ChrW(769)
                    Chr = "ы"
                Case "э" & ChrW(769)
                    Chr = "э"
                Case "ю" & ChrW(769)
                    Chr = "ю"
                Case "я" & ChrW(769)
                    Chr = "я"
                
                Case "А" & ChrW(769)
                    Chr = "А"
                Case "Е" & ChrW(769)
                    Chr = "Е"
                Case "Ё" & ChrW(769)
                    Chr = "Ё"
                Case "И" & ChrW(769)
                    Chr = "И"
                Case "О" & ChrW(769)
                    Chr = "О"
                Case "У" & ChrW(769)
                    Chr = "У"
                Case "Ы" & ChrW(769)
                    Chr = "Ы"
                Case "Э" & ChrW(769)
                    Chr = "Э"
                Case "Ю" & ChrW(769)
                    Chr = "Ю"
                Case "Я" & ChrW(769)
                    Chr = "Я"
            End Select
           
        End With
     Next
End Sub

Изменено: Alex_Gur - 06.11.2023 11:00:50

Перейти

Как убрать ударение макросом? VBA

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

05.11.2023 23:53:43

Макрос для быстрой установки ударения (для Word):

Код

Sub Udarenie1()
'
' установить курсор после буквы, над которой нужно поставить ударение
'
    Selection.TypeText Text:="301"
    Selection.ToggleCharacterCode
End Sub

Перейти

Как убрать ударение макросом? VBA

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

05.11.2023 22:33:02

Уважаемые коллеги!
Поскольку столкнулся с тем, что предыдущий макрос некорректно удаляет некоторые ударения, я предлагаю еще один макрос для удаления ударений.
Он менее элегантный, чем предыдущий, но работает надежнее.
Макрос написан для MS Word, но при необходимости желающие могут преобразовать его в Excel.
Поскольку макрос производит перебор всех символов, то для больших текстов он может работать долго.

Код

Sub Udalit_Udarenia1()
     'перебор всех символов
     Dim Chr As Object
     For Each Chr In ActiveDocument.Characters
        With Chr
            'Всего гласных букв в русском языке насчитывается 10:
            'а, е, ё, и, о, у, ы, э, ю, я.

            Select Case Chr
                Case "а" & ChrW(769)
                    Chr = "а"
                Case "е" & ChrW(769)
                    Chr = "е"
                Case "ё" & ChrW(769)
                    Chr = "ё"
                Case "и" & ChrW(769)
                    Chr = "и"
                Case "о" & ChrW(769)
                    Chr = "о"
                Case "у" & ChrW(769)
                    Chr = "у"
                Case "ы" & ChrW(769)
                    Chr = "ы"
                Case "э" & ChrW(769)
                    Chr = "э"
                Case "ю" & ChrW(769)
                    Chr = "ю"
                Case "я" & ChrW(769)
                    Chr = "я"
                
                Case "А" & ChrW(769)
                    Chr = "А"
                Case "Е" & ChrW(769)
                    Chr = "Е"
                Case "Ё" & ChrW(769)
                    Chr = "Ё"
                Case "И" & ChrW(769)
                    Chr = "И"
                Case "О" & ChrW(769)
                    Chr = "О"
                Case "У" & ChrW(769)
                    Chr = "У"
                Case "Ы" & ChrW(769)
                    Chr = "Ы"
                Case "Э" & ChrW(769)
                    Chr = "Э"
                Case "Ю" & ChrW(769)
                    Chr = "Ю"
                Case "Я" & ChrW(769)
                    Chr = "Я"
            End Select
           
        End With
     Next
End Sub

Прикладываю к этому сообщению файл Word для тестирования удаления ударений.

Изменено: Alex_Gur - 05.11.2023 22:39:01 (Редактирование и добавление тестового файла)

Перейти

Как убрать ударение макросом? VBA

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

11.09.2023 12:02:32

Мне также понадобилось удалить из текста все ударения с кодом 301, и меня заинтересовала эта проблема.

Кажется, мне удалось отделить символ с ударением от первого символа, о чем пишет Антон.

Макрос написан для MS Word, но при необходимости желающие могут преобразовать его в Excel.

Предлагаю следующий макрос для удаления ударений по всему тексту. Он получился не очень элегантным (так как приходится перебирать все символы текста), но должен работать корректно.
Для больших текстов данный макрос может работать долго, и можно порекомендовать обрабатывать большие тексты по частям.

Код

Sub RemovingAcuteAccents()
    Dim rng As Range
    
    ' Выделение всего текста
    Selection.WholeStory
    
    str1 = Selection
    For i = 1 To Len(str1) - 1
        ' Макрос просматривает все символы. Среди них могут быть символы Ударение с кодом 301 (ChrW(769))
        ' Символы Ударение удаляются
        Set rng = ActiveDocument.Range(Start:=i - 1, End:=i)
        ' Диапазон rng здесь содержит очередной символ текста, который преобразуется в выделение,
        ' для того чтобы этот символ можно было при необходимости удалить
        rng.Select
        ' Проверяем, является ли выделенный символ ударением,
        ' и если да, то удаляем этот символ
        If Selection = ChrW(769) Then
            Selection.Delete Unit:=wdCharacter, Count:=1
            ' Так как общее количество символов после удаления ударения меняется,
            ' приходится изменить и счетчик
            i = i - 1
        End If
        
        ' Так как некоторое количество символов мы удаляем,
        ' общее количество символов в файле также меняется,
        ' и это количество приходится пересчитывать
        
        ' Выделение всего текста
        Selection.WholeStory

        If i > Len(Selection) - 1 Then
            ' Завершение макроса
            ' Снятие выделения в конце макроса
            Selection.MoveRight Unit:=wdCharacter, Count:=1
            ' Выход из макроса
            Exit Sub
        End If
    Next
End Sub

Перейти

Закрыта личная книга макросов. Не получается запись.

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

05.11.2021 09:32:43

Цитата
МатросНаЗебре написал: ПопробуйтеФайл - Параметры - Надстройки - Управление - Отключённые объекты - ПерейтиИ там включить Personal.

Спасибо. Мне тоже помог этот совет.
После выполнения указанных действий нужно перезагрузить Excel.
Интересно, что все мои макросы в отключенных настройках сохранились.

Изменено: Alex_Gur - 05.11.2021 09:43:23

Перейти

Как выгрузить электронные адреса получателей из Outlook в Excel

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

30.01.2018 10:37:40

Большое спасибо, ZVI !
Я тоже не обратил внимания на Recipients.
Теперь код получается такой (работает прекрасно!).

Код

Sub main2() 'запускаем эту процедуру в Excel

    Dim olApp   As Object 'Outlook.Application
    Dim fldr    As Object 'Outlook.Folder
    Dim Item1    As Object 'Сообщение
    Dim Recipient1    As Object 'Адресаты
    
    Set olApp = CreateObject("Outlook.Application")
    
'    'обрабатываем папку Контакты
'    PrintInCell ("Папка Контакты")
'    Set fldr = olApp.Session.GetDefaultFolder(10)  '10 = olFolderContacts
'    For Each Item1 In fldr.Items
'        'Выписываем адресатов
'        str1 = Item1.Email1Address
'        PrintInCell (str1)
'        ActiveCell.Offset(-1, 1).Range("A1").Select
'        str1 = Item1.Subject
'        PrintInCell (str1)
'        ActiveCell.Offset(0, -1).Range("A1").Select
'    Next
'    PrintInCell ("")
'    PrintInCell ("")
    
    'обрабатываем папку Отправленные
    PrintInCell ("Адресаты из папки Отправленные")
    Set fldr = olApp.Session.GetDefaultFolder(5)  '5 = olFolderSentMail
    'Call processFolder(fldr)
    For Each Item1 In fldr.Items
        'Выписываем адресатов
        If Item1.Class = 43 Then  'сообщения -  Class = 43
            If Item1.Recipients.Count > 0 Then
                For Each Recipient1 In Item1.Recipients
                    str1 = Recipient1.Address
                    PrintInCell (str1)
                Next
            End If
        End If
    Next

End Sub


Sub PrintInCell(val1 As String)
     'Пользовательская функция записи
    ActiveCell.Value = val1
    ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

Изменено: Alex_Gur - 01.10.2018 17:19:24

Перейти

Как выгрузить электронные адреса получателей из Outlook в Excel

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

29.01.2018 21:50:24

Цитата
БМВ написал: Похоже путь Ваш в локальную адресную книгу лежит. Outlook подменяет адрес на имя. Соответвенно, вам нужно по имени извелекать E-Mail.

К сожалению, в папке Контакты у меня записано не так много адресов. Васи Пупкина там нет.
Адресная книга и Контакты в Outlook - это одно и то же?

Изменено: Alex_Gur - 29.01.2018 21:50:39

Перейти

Как выгрузить электронные адреса получателей из Outlook в Excel

Alex_Gur

Пользователь

Сообщений: 8 Регистрация: 29.01.2018

29.01.2018 20:57:45

Уважаемые коллеги!

Мне нужно выгрузить адреса получателей из папки Отправленные Outlook в файл Excel.
Написал следующий макрос:

Код

Sub main2() 'запускаем эту процедуру из Excel

    Dim olApp   As Object 'Outlook.Application
    Dim fldr    As Object 'Outlook.Folder
    
    Set olApp = CreateObject("Outlook.Application")
    
    'обрабатываем папку Отправленные
    PrintInCell ("Адресаты из папки Отправленные")
    Set fldr = olApp.Session.GetDefaultFolder(5)  '5 = olFolderSentMail

    For Each Item1 In fldr.Items
        'Выписываем адресатов
        If Item1.Class = 43 Then  'сообщения -  Class = 43
            str1 = Item1.To
            PrintInCell (str1)
            str1 = Item1.CC
            PrintInCell (str1)
            str1 = Item1.BCC
            PrintInCell (str1)
        End If
    Next

End Sub


Sub PrintInCell(val1 As String)
     'Пользовательская функция записи
    ActiveCell.Value = val1
    ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

Все работает хорошо, но вместо электронного адреса часто выдаются ФИО получателя.
У атрибутов To, CC и BCC дочерних атрибутов нет.
Подскажите, пожалуйста, как выгрузить именно электронный адрес?
Ведь в системе электронный адрес имеется (см. скриншот в приложении). И выгрузка Файл - Импорт и экспорт также показывает и ФИО, и электронный адрес.
Как можно получить этот электронный адрес, зная ФИО?

Перейти