Note: The other languages of the website are Google-translated. Back to English

Как отправить сразу несколько черновиков в Outlook?

Если в вашей папке «Черновики» есть несколько черновиков сообщений, и теперь вы хотите отправить их сразу, не отправляя одно за другим. Как можно быстро и легко справиться с этой работой в Outlook?

Отправлять все черновики сообщений сразу в Outlook с кодом VBA


Отправлять все черновики сообщений сразу в Outlook с кодом VBA

Следующие коды VBA могут помочь вам отправить все или выбранные черновики писем из папки «Черновики» сразу. Сделайте следующее:

1. Удерживайте ALT + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.

2. Затем нажмите Вставить > Модули, скопируйте и вставьте приведенный ниже код в открытый пустой модуль, см. снимок экрана:

Код VBA: отправить все черновики писем сразу в Outlook:

Sub SendAllDraftEmails()
Dim xAccount As Account
Dim xDraftFld As Folder
Dim xItemCount As Integer
Dim xCount As Integer
Dim xDraftsItems As Outlook.Items
Dim xPromptStr As String
Dim xYesOrNo As Integer
Dim i As Long
Dim xCurFld As Folder
Dim xTmpFld As Folder
On Error Resume Next
xItemCount = 0
xCount = 0
Set xTmpFld = Nothing
Set xCurFld = Application.ActiveExplorer.CurrentFolder
For Each xAccount In Outlook.Application.Session.Accounts
    Set xDraftFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
    xItemCount = xItemCount + xDraftFld.Items.Count
    If xDraftFld.EntryID = xCurFld.EntryID Then
        Set xTmpFld = xCurFld.Parent
    End If
Next xAccount
Set xDraftFld = Nothing
If xItemCount > 0 Then
   xPromptStr = "Are you sure to send out all the drafts?"
    xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo, "Kutools for Outlook")
    If xYesOrNo = vbYes Then
        If Not xTmpFld Is Nothing Then
            Set Application.ActiveExplorer.CurrentFolder = xTmpFld
        End If
        VBA.DoEvents
        For Each xAccount In Outlook.Application.Session.Accounts
            Set xDraftFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
            Set xDraftsItems = xDraftFld.Items
            For i = xDraftsItems.Count To 1 Step -1
                If xDraftsItems.Item(i).Recipients.Count <> 0 Then
                    xDraftsItems.Item(i).sEnd
                    xCount = xCount + 1
                End If
            Next
        Next xAccount
        VBA.DoEvents
        Set Application.ActiveExplorer.CurrentFolder = xCurFld
        MsgBox "Successfully sent " & xCount & " messages", vbInformation, "Kutools for Outlook"
    End If
Else
    MsgBox "No Drafts!", vbInformation + vbOKOnly, "Kutools for Outlook"
End If
End Sub

3. Затем сохраните код и нажмите F5 нажмите клавишу для запуска этого кода, появится всплывающее окно с напоминанием о том, что если вы отправите все черновики, нажмите Да, см. снимок экрана:

4. И появится диалоговое окно, чтобы напомнить вам, сколько черновиков писем было отправлено, см. Снимок экрана:

5, Затем нажмите OK кнопку, все электронные письма в Шашки папка будет отправлена ​​сразу, см. снимок экрана:

Ноты:

1. Приведенный выше код отправит все черновики писем со всех учетных записей в вашем Outlook.

2. Если вы просто хотите отправить определенные электронные письма из папки «Черновики», примените следующий код VBA:

Код VBA: отправлять выбранные письма из папки «Черновики»:

Sub SendSelectedDraftEmails()
Dim xSelection As Selection
Dim xPromptStr As String
Dim xYesOrNo As Integer
Dim i As Long
Dim xAccount As Account
Dim xCurFld As Folder
Dim xDraftsFld As Folder
Dim xTmpFld As Folder
Dim xArr() As String
Dim xCount As Integer
Dim xMail As MailItem
On Error Resume Next
xCount = 0
Set xTmpFld = Nothing
Set xCurFld = Application.ActiveExplorer.CurrentFolder
For Each xAccount In Outlook.Application.Session.Accounts
    Set xDraftsFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
    If xDraftsFld.EntryID = xCurFld.EntryID Then
        Set xTmpFld = xCurFld.Parent
    End If
Next xAccount
If xTmpFld Is Nothing Then
    MsgBox "The current folder is not a draft folder", vbInformation, "Kutools for Outlook"
    Exit Sub
End If
Set xSelection = Outlook.Application.ActiveExplorer.Selection
If xSelection.Count > 0 Then
    xPromptStr = "Are you sure to send out the selected " & xSelection.Count & " draft item(s)?"
    xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo, "Kutools for Outlook")
    If xYesOrNo = vbYes Then
        ReDim xArr(xSelection.Count - 1)
        For i = 1 To xSelection.Count
            xArr(i - 1) = xSelection.Item(i).EntryID
        Next
        Set Application.ActiveExplorer.CurrentFolder = xTmpFld
        VBA.DoEvents
        For i = 0 To UBound(xArr)
            Set xMail = Application.Session.GetItemFromID(xArr(i))
            If xMail.Recipients.Count <> 0 Then
                xMail.sEnd
                xCount = xCount + 1
            End If
        Next
        VBA.DoEvents
        Set Application.ActiveExplorer.CurrentFolder = xCurFld
        MsgBox "Successfully sent " & xCount & " messages", vbInformation, "Kutools for Outlook"
    End If
Else
    MsgBox "No items selected!", vbInformation, "Kutools for Outlook"
End If
End Sub

Статьи по теме:

Как отправить электронное письмо нескольким получателям по отдельности в Outlook?

Как отправлять персонализированные массовые электронные письма в список из Excel через Outlook?

Как отправить календарь нескольким получателям по отдельности в Outlook?

Как отправить электронное письмо нескольким получателям без их ведома в Outlook?


Kutools for Outlook - добавляет в Outlook 100 расширенных функций и делает работу намного проще!

  • Авто CC / BCC по правилам при отправке электронной почты; Автопересылка Несколько писем по индивидуальному заказу; Автоответчик без сервера обмена и дополнительных автоматических функций ...
  • Предупреждение BCC - показать сообщение при попытке ответить всем если ваш почтовый адрес находится в списке BCC; Напоминать об отсутствии вложений, и многое другое напоминает функции ...
  • Ответить (всем) со всеми вложениями в почтовой беседе; Ответить на много писем в секундах; Автоматическое добавление приветствия при ответе; Добавить дату в тему ...
  • Инструменты для вложений: управление всеми вложениями во всех письмах, Авто отсоединение, Сжать все, Переименовать все, сохранить все ... Быстрый отчет, Подсчет выбранных писем...
  • Мощные нежелательные электронные письма по обычаю; Удаление повторяющихся писем и контактов... Позвольте вам делать в Outlook умнее, быстрее и лучше.
выстрел kutools outlook kutools tab 1180x121
выстрел kutools outlook kutools plus tab 1180x121
 
Сортировать комментарии по
Комментарии (15)
Оценок пока нет. Оцените первым!
Этот комментарий был сведен к минимуму модератором на сайте
Блестяще, получилось красиво, спасибо :)
Этот комментарий был сведен к минимуму модератором на сайте
einfach nur perfekt. Герцлихен Данк
Этот комментарий был сведен к минимуму модератором на сайте
Скопировал, как указано выше, но когда я нажимаю F5, ничего не происходит.
Этот комментарий был сведен к минимуму модератором на сайте
Привет, Кэтлин,
Приведенный выше код отлично работает в моем Outlook. Какую версию Outlook вы используете?
Этот комментарий был сведен к минимуму модератором на сайте
У меня несколько аккаунтов на бирже. Я хочу, чтобы одна из учетных записей, которая не используется по умолчанию, была отправителем. Куда бы я вставил это в код? Спасибо!
Этот комментарий был сведен к минимуму модератором на сайте
Кто-нибудь получает электронные письма, отправленные в удаленную папку, делая это?
Этот комментарий был сведен к минимуму модератором на сайте
Привет, Билл,
Вы хотите отправить несколько выбранных писем из удаленного источника?
Пожалуйста, опишите вашу проблему более подробно, спасибо!
Этот комментарий был сведен к минимуму модератором на сайте
Привет Skyyang, я столкнулся с той же проблемой. Обычно я создаю 15-20 писем, а затем использую этот код, чтобы отправить их все сразу, но позже понимаю, что одно из этих писем не отправляется, а отправляется в мою папку «Удаленные». Даже в подсказке указано правильное количество писем, например: «Отправлено 20 писем», но когда я проверю, будет отправлено только 19, одно из которых я найду в папке с удаленными элементами. Я хочу, чтобы все электронные письма были отправлены их получателям без ошибок. Скажите, пожалуйста, почему это происходит? Пожалуйста помоги.
Этот комментарий был сведен к минимуму модератором на сайте
Привет, Даревин! Мы обновили приведенные выше коды. Пожалуйста, попробуйте еще раз, спасибо!
Этот комментарий был сведен к минимуму модератором на сайте
Та же проблема: если вы выберете 4 сообщения, после отправки трех из них они попадут в корзину (из-за оператора «xDraftsItems.Item(i).Delete»).
Этот комментарий был сведен к минимуму модератором на сайте
Мы использовали сценарий для отправки всех черновиков писем одновременно для пакета писем с заявлениями, сгенерированных из sage 200. Электронные письма в отправленных элементах выглядят нормально, но клиенты получают их с основным текстом на китайском языке! Любые идеи, что может происходить здесь?
Этот комментарий был сведен к минимуму модератором на сайте
Можете ли вы объяснить, почему последнее письмо (i = 1) воссоздается в новом MailItem, а не просто в .Send?

Благодарю.
Этот комментарий был сведен к минимуму модератором на сайте
Привет, быстрый вопрос, может быть, у вас есть идея. У нас есть внешнее приложение, которое сохраняет все письма в папку черновиков. если я запускаю макрос, у нас возникает проблема, что только первое письмо в списке отправляется правильно, все остальные письма откладываются, потому что он добавляет кавычки ' ' к почтовому адресу. Есть ли способ избежать этого?
Этот комментарий был сведен к минимуму модератором на сайте
Этот код отправляет все черновики в подпапку под названием «Инструменты слияния» (он спрашивает вас перед отправкой). Я уверен, что вы, ребята, можете отредактировать его в соответствии с вашими потребностями. Это намного проще. Наслаждаться :)
Sub SendAllMergeToolsDrafts()

If MsgBox("Вы уверены, что хотите отправить ВСЕ элементы из папки черновиков инструментов слияния?", _
vbQuestion + vbYesNo) <> vbYes Затем выйти из подпрограммы

Dim myNamespace As Outlook.NameSpace 'Изменить представление на папку "Входящие", чтобы избежать встроенной ошибки
Set myNamespace = Application.GetNamespace("MAPI") 'Изменить представление на папку "Входящие", чтобы избежать встроенной ошибки
Установить Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Изменить представление на папку "Входящие", чтобы избежать встроенной ошибки

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Folders("Инструменты слияния") 'Отправляет все черновики только в папку Инструменты слияния
intCount = 0
Делать, пока fldDraft.Items.count > 0
Установить msg = fldDraft.Items(1)
msg.Отправить
intCount = intCount + 1
Петля
Если нет (msg Is Nothing), то установите msg = Nothing
Установить fldDraft = ничего
MsgBox intCount & "Сообщения отправлены", vbInformation + vbOKOnly

End Sub
Этот комментарий был сведен к минимуму модератором на сайте
Привет, ребята. Думал поделюсь. Вот мой код для отправки всех черновиков:
Sub SendAllDrafts() 'От jamesmalcolmwood@gmail.com

If MsgBox("Вы уверены, что хотите отправить ВСЕ элементы из папки черновиков?", _
vbQuestion + vbYesNo) <> vbYes Затем выйти из подпрограммы

Dim myNamespace As Outlook.NameSpace 'Изменить представление на папку "Входящие", чтобы избежать встроенной ошибки
Set myNamespace = Application.GetNamespace("MAPI") 'Изменить представление на папку "Входящие", чтобы избежать встроенной ошибки
Установить Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Изменить представление на папку "Входящие", чтобы избежать встроенной ошибки

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts) 'Отправляет все черновики в вашу основную папку черновиков. Для подпапки добавьте .Folders("имя папки")
intCount = 0
Делать, пока fldDraft.Items.count > 0
Установить msg = fldDraft.Items(1)
msg.Отправить
intCount = intCount + 1
Петля
Если нет (msg Is Nothing), то установите msg = Nothing
Установить fldDraft = ничего
MsgBox intCount & "Сообщения отправлены", vbInformation + vbOKOnly

End Sub
Здесь еще нет комментариев
Оставляйте свои комментарии
Публикация как гость
×
Оценить этот пост:
0   Характеристики
Предлагаемые места

Подписывайтесь на Нас

Copyright © 2009 - www.extendoffice.ком. | Все права защищены. Питаться от ExtendOffice, | Карта сайта
Microsoft и логотип Office являются товарными знаками или зарегистрированными товарными знаками Microsoft Corporation в США и / или других странах.
Защищено Sectigo SSL