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.
