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

Jak v aplikaci Outlook odeslat více konceptů najednou?

Pokud je ve složce Koncepty více konceptů zpráv, nyní je chcete odeslat najednou, aniž byste je odesílali po jedné. Jak byste se mohli s touto prací vypořádat rychle a snadno v Outlooku?

Odesílejte všechny koncepty zpráv najednou v Outlooku s kódem VBA


Odesílejte všechny koncepty zpráv najednou v Outlooku s kódem VBA

Následující kódy VBA vám pomohou odeslat všechny nebo vybrané koncepty e-mailů ze složky Koncepty najednou, postupujte takto:

1. Podržte ALT + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2. Pak klikněte na tlačítko Vložit > Modul, zkopírujte a vložte pod kód do otevřeného prázdného modulu, viz screenshot:

Kód VBA: Odesílejte všechny koncepty e-mailů najednou v Outlooku:

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. Poté kód uložte a stiskněte F5 klíč ke spuštění tohoto kódu, zobrazí se okno s výzvou, které vám připomene, zda odeslat všechny koncepty, klepněte na Ano, viz screenshot:

4. Zobrazí se dialogové okno, které vám připomene, kolik konceptů e-mailů bylo odesláno, viz screenshot:

5. A pak klikněte na tlačítko OK tlačítko, všechny e-maily v dáma složka bude odeslána najednou, viz screenshot:

Poznámky:

1. Výše ​​uvedený kód odešle všechny koncepty e-mailů ze všech účtů ve vašem Outlooku.

2. Pokud chcete pouze poslat nějaké konkrétní e-maily ze složky Koncepty, použijte následující kód VBA:

Kód VBA: Odeslání vybraných e-mailů ze složky Koncepty:

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

Související články:

Jak poslat e-mail více příjemcům jednotlivě v aplikaci Outlook?

Jak posílat osobní hromadné e-maily do seznamu z aplikace Excel pomocí aplikace Outlook?

Jak poslat kalendář více příjemcům jednotlivě v aplikaci Outlook?

Jak posílat e-maily více příjemcům, aniž by o tom věděli v aplikaci Outlook?


Kutools pro Outlook - přináší do aplikace Outlook 100 pokročilých funkcí a usnadňuje práci!

  • Auto CC / BCC podle pravidel při odesílání e-mailů; Automatické předávání Více e-mailů podle zvyku; Automatická odpověď bez serveru Exchange a dalších automatických funkcí ...
  • Varování BCC - zobrazit zprávu, když se pokusíte odpovědět všem pokud je vaše e-mailová adresa v seznamu BCC; Připomenout, když chybí přílohya další připomínající funkce ...
  • Odpovědět (Vše) Se všemi přílohami v e-mailové konverzaci; Odpovězte na mnoho e-mailů během několika sekund; Automatické přidání pozdravu při odpovědi; Přidat datum do předmětu ...
  • Nástroje pro přílohy: Spravujte všechny přílohy ve všech e-mailech, Automatické odpojení, Komprimovat vše, Přejmenovat vše, Uložit vše ... Rychlá zpráva, Počítat vybrané e-maily...
  • Výkonné nevyžádané e-maily podle zvyku; Odeberte duplicitní e-maily a kontakty... Umožní vám dělat chytřejší, rychlejší a lepší v Outlooku.
záběr kutools outlook kutools tab 1180x121
shot kutools outlook kutools plus karta 1180x121
 
Komentáře (15)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
Skvělé, fungovalo to kouzlo, děkuji :)
Tento komentář byl moderátorem webu minimalizován
einfach nur perfektní. Herzlichen Dank
Tento komentář byl moderátorem webu minimalizován
Zkopírováno podle výše uvedeného, ​​ale když stisknu F5, nic se nestane
Tento komentář byl moderátorem webu minimalizován
Ahoj, Cathleen,
Výše uvedený kód funguje v mém Outlooku dobře, jakou verzi Outlooku používáte?
Tento komentář byl moderátorem webu minimalizován
Mám více výměnných účtů. Chci mít jeden z účtů, který není mým výchozím, jako odesílatele. Kam bych to vložil do kódu? Dík!
Tento komentář byl moderátorem webu minimalizován
Dostává někdo nějaké e-maily do smazané složky, když to dělá?
Tento komentář byl moderátorem webu minimalizován
Ahoj Bille,
Chcete odeslat více vybraných e-mailů z odstraněného zdroje?
Uveďte prosím svůj problém podrobněji, děkuji!
Tento komentář byl moderátorem webu minimalizován
Ahoj skyyang, potýkám se se stejným problémem. Obvykle navrhuji 15-20 e-mailů a poté pomocí tohoto kódu odešlem všechny najednou, ale později si uvědomím, že jeden z těchto e-mailů se neodešle, ale odešle se do mé složky 'Deleted'. Dokonce i výzva říká správný počet e-mailů, např.: '20 e-mailů odesláno', ale když zkontroluji, bylo odesláno pouze 19, jeden najdu, že leží ve složce smazaných položek. Chci, aby všechny e-maily byly odeslány jejich příjemcům bez chyby. Můžete mi prosím říct, proč se to děje? Prosím pomozte.
Tento komentář byl moderátorem webu minimalizován
Ahoj, Darewine, aktualizovali jsme výše uvedené kódy, zkuste to prosím znovu, děkujeme!
Tento komentář byl moderátorem webu minimalizován
Stejný problém: pokud vyberete 4 zprávy, po odeslání tří z nich jsou ve složce koše (kvůli příkazu "xDraftsItems.Item(i).Delete")
Tento komentář byl moderátorem webu minimalizován
Skript jsme použili k odeslání všech konceptů e-mailů najednou pro dávku e-mailů s výpisy generovaných z šalvěje 200. E-maily v odeslaných položkách vypadají dobře, ale zákazníci je dostávají s hlavním textem v čínštině! Nějaké nápady, co by se tu mohlo stát?
Tento komentář byl moderátorem webu minimalizován
Můžete vysvětlit, proč je poslední e-mail (i = 1) znovu vytvořen v nové položce MailItem namísto pouhého .Send?

Díky.
Tento komentář byl moderátorem webu minimalizován
Ahoj, rychlý dotaz, možná máte nápad. Máme externí aplikaci, která ukládá všechny maily do složky koncepty. pokud spustím makro, máme problém, že pouze první e-mail v seznamu je odeslán správně, všechny ostatní e-maily jsou odloženy, protože přidává uvozovky ' ' k e-mailové adrese. Existuje způsob, jak se tomu vyhnout?
Tento komentář byl moderátorem webu minimalizován
Tento kód odešle všechny koncepty do podsložky nazvané Merge Tools (před odesláním se vás zeptá). Jsem si jistý, že ho můžete upravit tak, aby vyhovoval vašim potřebám. Je to daleko jednodušší. Užívat si :)
Sub SendAllMergeToolsDrafts()

If MsgBox("Opravdu chcete odeslat VŠECHNY položky ve složce konceptů Nástroje pro sloučení?", _
vbQuestion + vbYesNo) <> vbYes Potom Exit Sub

Dim myNamespace As Outlook.NameSpace 'Změňte zobrazení na Doručená pošta, abyste předešli chybám v textu
Set myNamespace = Application.GetNamespace("MAPI") 'Změňte zobrazení na Doručená pošta, abyste se vyhnuli chybě inline
Nastavit Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Změňte zobrazení na Doručená pošta, abyste se vyhnuli chybě inline

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Folders("Merge Tools") 'Odešle všechny koncepty pouze ve složce Merge Tools
intCount = 0
Do While fldDraft.Items.count > 0
Set msg = fldDraft.Items(1)
msg.Send
intCount = intCount + 1
Smyčka
Pokud ne (zpráva není nic), nastavte zprávu = nic
Nastavte fldDraft = Nic
MsgBox intCount & "zprávy odeslány", vbInformation + vbOKOnly

End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj kluci. Myslel jsem, že se podělím. Zde je můj kód pro odesílání všech konceptů:
Sub SendAllDrafts() 'Od jamesmalcolmwood@gmail.com

Pokud MsgBox("Opravdu chcete odeslat VŠECHNY položky ve složce konceptů?", _
vbQuestion + vbYesNo) <> vbYes Potom Exit Sub

Dim myNamespace As Outlook.NameSpace 'Změňte zobrazení na Doručená pošta, abyste předešli chybám v textu
Set myNamespace = Application.GetNamespace("MAPI") 'Změňte zobrazení na Doručená pošta, abyste se vyhnuli chybě inline
Nastavit Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Změňte zobrazení na Doručená pošta, abyste se vyhnuli chybě inline

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts) 'Odešle všechny koncepty ve vaší hlavní složce konceptů. Pro podsložku přidejte .Folders("název složky")
intCount = 0
Do While fldDraft.Items.count > 0
Set msg = fldDraft.Items(1)
msg.Send
intCount = intCount + 1
Smyčka
Pokud ne (zpráva není nic), nastavte zprávu = nic
Nastavte fldDraft = Nic
MsgBox intCount & "zprávy odeslány", vbInformation + vbOKOnly

End Sub
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL