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

Hogyan küldhet több piszkozatot egyszerre az Outlookban?

Ha több piszkozat van a Piszkozatok mappában, most ezeket egyszerre szeretné elküldeni, anélkül, hogy egyesével küldené. Hogyan tudná gyorsan és egyszerűen kezelni ezt a munkát az Outlook programban?

Az összes üzenetvázlatot egyszerre küldje el az Outlookban VBA kóddal


Az összes üzenetvázlatot egyszerre küldje el az Outlookban VBA kóddal

A következő VBA kódok segíthetnek az összes vagy a kiválasztott e-mail vázlatok elküldésében a Piszkozatok mappából egyszerre, kérjük, tegye a következőket:

1. Tartsa lenyomva a ALT + F11 billentyűk megnyitásához Microsoft Visual Basic for Applications ablak.

2. Ezután kattintson betétlap > Modulok, másolja és illessze be a kódot a megnyitott üres modulba, lásd a képernyőképet:

VBA kód: Az összes e-mail tervezet küldése egyszerre az Outlookban:

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. Ezután mentse el a kódot, és nyomja meg a gombot F5 gombot a kód futtatásához, megjelenik egy prompt doboz, amely emlékezteti Önt, ha elküldi az összes piszkozatot, kattintson a gombra Igen, lásd a képernyőképet:

4. És megjelenik egy párbeszédpanel, amely emlékezteti Önt, hogy hány e-mail vázlatot küldtek ki, lásd a képernyőképet:

5. Kattintson a gombra OK gombra, az összes e-mailt a Piszkozatok mappa azonnal el lesz küldve, lásd a képernyőképet:

Megjegyzések:

1. A fenti kód elküldi az összes e-mail vázlatot az Outlook összes fiókjáról.

2. Ha csak néhány konkrét e-mailt szeretne elküldeni a Piszkozatok mappából, kérjük, alkalmazza a következő VBA kódot:

VBA kód: A kiválasztott e-mailek elküldése a Piszkozatok mappából:

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

Kapcsolódó cikkek:

Hogyan küldjön e-mailt több címzettnek egyenként az Outlookban?

Hogyan küldhet személyre szabott tömeges e-maileket listára az Excelből az Outlook segítségével?

Hogyan küldhetünk naptárat több címzettnek egyenként az Outlookban?

Hogyan küldhet e-mailt több címzettnek anélkül, hogy tudná őket az Outlookban?


Kutools for Outlook - 100 speciális funkciót hoz az Outlookba, és sokkal könnyebbé teszi a munkát!

  • Auto CC / BCC szabályok szerint e-mail küldéskor; Automatikus továbbítás Több e-mail egyedi; Autómatikus válasz csere szerver és további automatikus funkciók nélkül ...
  • BCC figyelmeztetés - üzenet megjelenítése, amikor megpróbál válaszolni az összesre ha az e-mail címed szerepel a BCC listában; Emlékeztessen a hiányzó mellékletekre, és további funkciók emlékeztetnek ...
  • Válasz (minden) az összes melléklettel az e-mail beszélgetésben; Válasz sok e-mailre másodpercek alatt; Automatikus üdvözlet hozzáadása amikor válasz; Dátum hozzáadása a tárgyhoz ...
  • Mellékleteszközök: Az összes levél összes mellékletének kezelése, Automatikus leválasztás, Tömörítsen mindent, Átnevezés, Összes mentése ... Gyorsjelentés, Számolja ki a kiválasztott leveleket...
  • Erőteljes levélszemét szokás szerint; Távolítsa el az ismétlődő leveleket és névjegyeket... Lehetővé teszi, hogy okosabban, gyorsabban és jobban végezze el az Outlook programot.
lövés kutools outlook kutools fül 1180x121
shot kutools outlook kutools plus tab 1180x121
 
A megjegyzések rendezése szerint
Hozzászólások (15)
Még nincs értékelés. Legyen Ön az első, aki értékel!
A weboldal moderátora ezt a megjegyzést minimalizálta
Zseniális, remekül sikerült, köszönöm :)
A weboldal moderátora ezt a megjegyzést minimalizálta
einfach nur perfekt. Herzlichen Dank
A weboldal moderátora ezt a megjegyzést minimalizálta
A fentiek szerint másolva, de ha megnyomom az F5-öt, nem történik semmi
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Cathleen,
A fenti kód jól működik az Outlookban, melyik Outlook verziót használja?
A weboldal moderátora ezt a megjegyzést minimalizálta
Több csereszámlám van. Azt akarom, hogy az egyik fiók legyen a feladó, amely nem az alapértelmezett. Ezt hova írjam be a kódba? Kösz!
A weboldal moderátora ezt a megjegyzést minimalizálta
Kap valaki e-mailt a törölt mappába ezzel kapcsolatban?
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Bill,
Több kiválasztott e-mailt szeretne küldeni a törölt mappából?
Kérjük, írja le részletesebben a problémáját, köszönöm!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Skyyang, én is ugyanezzel a problémával küzdök. Általában 15-20 e-mailt vázolok, majd ezzel a kóddal küldöm el egyszerre, de később rájövök, hogy az egyik ilyen e-mailt nem küldik el, hanem a „Törölt” mappába kerülnek. Még a prompt is kiírja az e-mailek helyes számát pl.: "20 e-mail elküldve", de ha megnézem, csak 19 lett volna elküldve, az egyiket a törölt elemek mappájában találom. Azt szeretném, ha az összes e-mailt hiba nélkül elküldené a címzetteknek. Kérem, mondja el, miért történik ez? Kérem, segítsen.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, Darewin! Frissítettük a fenti kódokat, próbáld újra! Köszönjük!
A weboldal moderátora ezt a megjegyzést minimalizálta
Ugyanaz a probléma: ha 4 üzenetet választ ki, három üzenet elküldése után a kukába kerül (az "xDraftsItems.Item(i).Delete" utasítás miatt)
A weboldal moderátora ezt a megjegyzést minimalizálta
A szkriptet arra használtuk, hogy az összes piszkozatot egyszerre elküldjük a sage 200-ból generált kivonat e-mailekhez. Az elküldött tételekben lévő e-mailek jól néznek ki, de az ügyfelek kínai nyelvű törzsszöveggel kapják meg őket! Van valami ötletetek, hogy mi történhet itt?
A weboldal moderátora ezt a megjegyzést minimalizálta
Meg tudná magyarázni, hogy az utolsó levél (i = 1) miért jön létre újra egy új MailItemben a .Send helyett?

Kösz.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, gyors kérdés, talán van ötleted. Van egy külső alkalmazásunk, amely az összes levelet a piszkozatok mappába menti. ha lefuttatom a makrót, akkor az a probléma, hogy csak az első levelet küldik el helyesen a listában, az összes többi levelet elhalasztja, mert idézőjeleket ad a mail címhez. Van mód ennek elkerülésére?
A weboldal moderátora ezt a megjegyzést minimalizálta
Ez a kód az összes vázlatot egy Merge Tools nevű almappába küldi (küldés előtt rákérdez). Biztos vagyok benne, hogy szerkesztheti az igényeinek megfelelően. Sokkal egyszerűbb. Élvezd :)
Sub SendAllMergeToolsDrafts()

If MsgBox("Biztosan el akarja küldeni az ÖSSZES elemet a Merge Tools piszkozatok mappájában?", _
vbQuestion + vbYesNo) <> vbYes Ezután lépjen ki a Sub

Dim myNamespace mint Outlook.NameSpace 'Változtassa meg a nézetet a Beérkezett üzenetek mappára, hogy elkerülje a szövegközi hibákat
Set myNamespace = Application.GetNamespace("MAPI") 'Változtassa meg a nézetet a Beérkezett üzenetek mappára a soron belüli hiba elkerülése érdekében
Állítsa be az Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Változtassa meg a nézetet Inboxra, hogy elkerülje a szövegközi hibákat

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Folders("Egyesítési eszközök") 'Csak a Merge Tools mappában található összes vázlatot küldi el
intCount = 0
Do While fldDraft.Items.count > 0
Set msg = fldDraft.Items(1)
msg.Send
intCount = intCount + 1
Hurok
Ha nem (msg Is Nothing), akkor Set msg = Semmi
Set fldDraft = Semmi
MsgBox intCount & " üzenetek elküldve", vbInformation + vbOKOnly

End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Sziasztok srácok. Gondoltam megosztom. Íme a kódom az összes piszkozat elküldéséhez:
Sub SendAllDrafts() 'Jamesmalcolmwood@gmail.com

If MsgBox("Biztosan el akarja küldeni a piszkozatok mappájában lévő ÖSSZES elemet?", _
vbQuestion + vbYesNo) <> vbYes Ezután lépjen ki a Sub

Dim myNamespace mint Outlook.NameSpace 'Változtassa meg a nézetet a Beérkezett üzenetek mappára, hogy elkerülje a szövegközi hibákat
Set myNamespace = Application.GetNamespace("MAPI") 'Változtassa meg a nézetet a Beérkezett üzenetek mappára a soron belüli hiba elkerülése érdekében
Állítsa be az Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Változtassa meg a nézetet Inboxra, hogy elkerülje a szövegközi hibákat

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts) 'Elküldi a fő piszkozatok mappájában lévő összes piszkozatot. Almappához adja hozzá a .Folders("mappanév") parancsot.
intCount = 0
Do While fldDraft.Items.count > 0
Set msg = fldDraft.Items(1)
msg.Send
intCount = intCount + 1
Hurok
Ha nem (msg Is Nothing), akkor Set msg = Semmi
Set fldDraft = Semmi
MsgBox intCount & " üzenetek elküldve", vbInformation + vbOKOnly

End Sub
Még senki sem írt megjegyzést
Hagyja meg észrevételeit
Feladás vendégként
×
Értékeld ezt a bejegyzést:
0   Karakterek
Javasolt helyek

Kövess minket

Copyright © 2009 - www.extendoffice.com. | Minden jog fenntartva. Powered by ExtendOffice. | Oldaltérkép
A Microsoft és az Office logó a Microsoft Corporation védjegyei vagy bejegyzett védjegyei az Egyesült Államokban és / vagy más országokban.
Sectigo SSL védi