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

Bagaimana cara mengirim beberapa draf sekaligus di Outlook?

Jika ada beberapa pesan draf di folder Draf Anda, dan sekarang, Anda ingin mengirimnya sekaligus tanpa mengirim satu per satu. Bagaimana Anda bisa menangani pekerjaan ini dengan cepat dan mudah di Outlook?

Kirim semua pesan draf sekaligus di Outlook dengan kode VBA


Kirim semua pesan draf sekaligus di Outlook dengan kode VBA

Kode VBA berikut dapat membantu Anda mengirim semua atau draf email yang dipilih dari folder Draf sekaligus, lakukan seperti ini:

1. Tahan ALT + F11 kunci untuk membuka Microsoft Visual Basic untuk Aplikasi jendela.

2. Lalu klik Menyisipkan > Modul, salin dan tempel kode di bawah ini ke dalam modul kosong yang dibuka, lihat tangkapan layar:

Kode VBA: Kirim semua draf email sekaligus di 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. Kemudian simpan kodenya, dan tekan F5 kunci untuk menjalankan kode ini, kotak prompt akan muncul untuk mengingatkan Anda jika mengirim semua draf, klik Yes, lihat tangkapan layar:

4. Dan kotak dialog akan muncul untuk mengingatkan Anda berapa banyak draf email yang telah dikirim, lihat tangkapan layar:

5. Dan kemudian klik OK tombol, semua email di Konsep folder akan dikirim sekaligus, lihat tangkapan layar:

Catatan:

1. Kode di atas akan mengirim semua draf email dari semua akun di Outlook Anda.

2. Jika Anda hanya ingin mengirim beberapa email tertentu dari folder Draf, harap terapkan kode VBA berikut:

Kode VBA: Kirim email yang dipilih dari folder Draf:

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

Artikel Terkait:

Bagaimana Cara Mengirim Email Ke Beberapa Penerima Secara Individual Di Outlook?

Bagaimana cara mengirim email massal yang dipersonalisasi ke daftar dari Excel melalui Outlook?

Bagaimana cara mengirim kalender ke beberapa penerima secara individual di Outlook?

Bagaimana cara mengirim email ke beberapa penerima tanpa mereka mengetahuinya di Outlook?


Kutools for Outlook - Menghadirkan 100 Fitur Canggih ke Outlook, dan Membuat Pekerjaan Lebih Mudah!

  • CC / BCC Otomatis dengan aturan saat mengirim email; Maju Otomatis Beberapa Email secara khusus; Balas otomatis tanpa server pertukaran, dan lebih banyak fitur otomatis ...
  • Peringatan BCC - tunjukkan pesan ketika Anda mencoba membalas semua jika alamat email Anda ada di daftar BCC; Ingatkan Saat Lampiran Hilang, dan lebih banyak fitur pengingat ...
  • Balas (Semua) Dengan Semua Lampiran di percakapan surat; Balas Banyak Email dalam hitungan detik; Tambah Salam Otomatis saat membalas; Tambahkan Tanggal ke dalam subjek ...
  • Alat Lampiran: Kelola Semua Lampiran di Semua Email, Lepaskan Otomatis, Kompres Semua, Ganti Nama Semua, Simpan Semua ... Laporan Cepat, Hitung Email yang Dipilih...
  • Email Sampah yang Kuat dengan kebiasaan; Hapus Duplikat Email dan Kontak... Memungkinkan Anda melakukan lebih cerdas, lebih cepat, dan lebih baik di Outlook.
shot kutools outlook tab kutools 1180x121
tembak kutools outlook kutools plus tab 1180x121
 
Urutkan komentar berdasarkan
komentar (15)
Belum ada peringkat. Jadilah yang pertama memberi peringkat!
Komentar ini diminimalkan oleh moderator di situs
Brilian, bekerja dengan pesona, terima kasih :)
Komentar ini diminimalkan oleh moderator di situs
einfach nur perfekt. Herzlichen Danko
Komentar ini diminimalkan oleh moderator di situs
Disalin seperti di atas tetapi ketika saya menekan F5 tidak ada yang terjadi
Komentar ini diminimalkan oleh moderator di situs
Hai, Cathleen,
Kode di atas berfungsi dengan baik di Outlook saya, versi Outlook mana yang Anda gunakan?
Komentar ini diminimalkan oleh moderator di situs
Saya memiliki beberapa akun pertukaran. Saya ingin memiliki salah satu akun yang bukan default saya sebagai pengirim. Di mana saya akan memasukkan ini ke dalam kode? Terima kasih!
Komentar ini diminimalkan oleh moderator di situs
Adakah yang mendapatkan beberapa email yang dikirim ke folder yang dihapus melakukan ini?
Komentar ini diminimalkan oleh moderator di situs
Hai, Bil,
Apakah Anda ingin mengirim beberapa email yang dipilih dari foder yang dihapus?
Tolong beri masalah Anda lebih detail, terima kasih!
Komentar ini diminimalkan oleh moderator di situs
Hai skyyang, saya menghadapi masalah yang sama. Saya biasanya menyusun 15-20 email dan kemudian menggunakan kode ini untuk mengirim semuanya sekaligus, tetapi kemudian menyadari bahwa salah satu email itu tidak terkirim, melainkan dikirim ke folder 'Dihapus' saya. Bahkan prompt mengatakan jumlah email yang benar untuk misalnya: '20 email terkirim' tetapi ketika saya memeriksa, hanya 19 yang akan dikirim, satu saya akan menemukannya tergeletak di folder item saya yang dihapus. Saya ingin semua email dikirim ke penerimanya tanpa kesalahan. Bisakah Anda memberi tahu saya mengapa ini terjadi. Tolong bantu.
Komentar ini diminimalkan oleh moderator di situs
Hai, Darewin, Kami telah memperbarui kode di atas, silakan coba lagi, terima kasih!
Komentar ini diminimalkan oleh moderator di situs
Masalah yang sama: jika Anda memilih 4 pesan, setelah mengirim tiga di antaranya berada di folder sampah (karena pernyataan "xDraftsItems.Item(i).Delete")
Komentar ini diminimalkan oleh moderator di situs
Kami menggunakan skrip untuk mengirim semua email draf sekaligus untuk kumpulan email pernyataan yang dihasilkan dari sage 200. Email dalam item terkirim terlihat baik-baik saja tetapi pelanggan menerimanya dengan teks isi dalam bahasa Mandarin! Ada ide apa yang bisa terjadi di sini?
Komentar ini diminimalkan oleh moderator di situs
Bisakah Anda menjelaskan mengapa email terakhir (i = 1) dibuat ulang di MailItem baru, bukan hanya .Send?

Terima kasih.
Komentar ini diminimalkan oleh moderator di situs
Hai, pertanyaan singkat mungkin Anda punya Ide. Kami memiliki aplikasi eksternal yang menyimpan semua email ke folder konsep. jika saya menjalankan makro, kami memiliki masalah, bahwa hanya email pertama dalam daftar yang dikirim dengan benar, semua email lainnya ditangguhkan karena menambahkan tanda kutip ' ' ke alamat email. Apakah ada cara untuk menghindari ini?
Komentar ini diminimalkan oleh moderator di situs
Kode ini mengirimkan semua draf dalam subfolder yang disebut Merge Tools (ini menanyakan Anda sebelum mengirim). Saya yakin kalian dapat mengeditnya sesuai dengan kebutuhan Anda. Ini jauh lebih sederhana. Menikmati :)
Sub SendAllMergeToolsDrafts()

If MsgBox("Apakah Anda yakin ingin mengirim SEMUA item di folder konsep Merge Tools Anda?", _
vbQuestion + vbYesNo) <> vbYes Kemudian Keluar Sub

Redupkan myNamespace Sebagai Outlook.NameSpace 'Ubah tampilan ke Kotak Masuk untuk menghindari kesalahan sebaris
Setel myNamespace = Application.GetNamespace("MAPI") 'Ubah tampilan ke Kotak Masuk untuk menghindari kesalahan sebaris
Setel Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Ubah tampilan ke Kotak Masuk untuk menghindari kesalahan sebaris

Redupkan fldDraft Sebagai MAPIFolder, msg Sebagai Outlook.MailItem, intCount Sebagai Integer
Setel fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Folders("Merge Tools") 'Mengirim semua draf di folder Merge Tools saja
intJumlah = 0
Lakukan Sementara fldDraft.Items.count > 0
Setel pesan = fldDraft.Items(1)
msg.Kirim
intHitung = intHitung + 1
Lingkaran
Jika Tidak (pesan Tidak Ada) Kemudian Atur msg = Tidak Ada
Setel fldDraft = Tidak ada
MsgBox intCount & "pesan terkirim", vbInformation + vbOKOnly

End Sub
Komentar ini diminimalkan oleh moderator di situs
Hai kawan. Pikir saya akan berbagi. Inilah kode saya untuk mengirim semua draf:
Sub SendAllDrafts() 'Oleh jamesmalcolmwood@gmail.com

If MsgBox("Apakah Anda yakin ingin mengirim SEMUA item di folder draft Anda?", _
vbQuestion + vbYesNo) <> vbYes Kemudian Keluar Sub

Redupkan myNamespace Sebagai Outlook.NameSpace 'Ubah tampilan ke Kotak Masuk untuk menghindari kesalahan sebaris
Setel myNamespace = Application.GetNamespace("MAPI") 'Ubah tampilan ke Kotak Masuk untuk menghindari kesalahan sebaris
Setel Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Ubah tampilan ke Kotak Masuk untuk menghindari kesalahan sebaris

Redupkan fldDraft Sebagai MAPIFolder, msg Sebagai Outlook.MailItem, intCount Sebagai Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts) 'Mengirim semua draft di folder draft utama Anda. Untuk subfolder, tambahkan .Folders("folder name")
intJumlah = 0
Lakukan Sementara fldDraft.Items.count > 0
Setel pesan = fldDraft.Items(1)
msg.Kirim
intHitung = intHitung + 1
Lingkaran
Jika Tidak (pesan Tidak Ada) Kemudian Atur msg = Tidak Ada
Setel fldDraft = Tidak ada
MsgBox intCount & "pesan terkirim", vbInformation + vbOKOnly

End Sub
Belum ada komentar yang diposting di sini
Tinggalkan komentar anda
Posting sebagai Tamu
×
Beri peringkat pos ini:
0   Karakter
Lokasi yang Disarankan

Ikuti kami

Hak Cipta © 2009 - www.extendoffice.com. | Seluruh hak cipta. Dipersembahkan oleh ExtendOffice. | Peta Situs
Microsoft dan logo Office adalah merek dagang atau merek dagang terdaftar dari Microsoft Corporation di Amerika Serikat dan / atau negara lain.
Dilindungi oleh Sectigo SSL