Mass Mail as Single Messages into Draft Folder (Outlook 2010)

[csvaasan]

Using Outlook 2010, I would like to send Job Messages Email to All the Candidates who already sent their resumes to us by email.

STAGE-1: The way I would like to do is I'll COMPOSE a NEW EMAIL, PASTE EMAIL IDs (say 25 email IDs copied from 25 resumes) into the "To field" of the Message.

Once I clicked the "Send" Button, it should keep 25 Individual Email Messages in the "Draft Folder" (where as, every email message will have ONLY ONE email ID in the "To

field").

STAGE-2: Sending all the 25 Messages from "Draft Folder"; for which the following Macro works well.

-------------------
Public Sub SendDrafts()

Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder

'Send all items in the "Drafts" folder that have a "To" address filled in.

'Setup Outlook

Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders

'Set Draft Folder.

Set myDraftsFolder = myFolders("SC").Folders("Drafts")

'Loop through all Draft Items

For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1

'Check for "To" address and only send if "To" is filled in.

If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then

'Send Item

myDraftsFolder.Items.Item(lDraftItem).Send

End If
Next lDraftItem

'Clean-up

Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing

End Sub
-------------------

QUESTION:

I need a Macro Code to accomplish STAGE-1 ALONE (Hope I can keep 2 Macros and I can run them one-by-one).

[Paleo]

STAGE-1 using your own code from STAGE-2:

Public Sub SepareDrafts()

Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
Dim objMailMessage As Outlook.MailItem
Dim emlBody, sendTo As String
Dim TOs

Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
Set myDraftsFolder = myNameSpace.PickFolder

For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
TOs = Split(myDraftsFolder.Items.Item(lDraftItem).To, ";")
For i = 0 To UBound(TOs)
Set objMailMessage = myOutlook.CreateItem(0)
With objMailMessage
.To = TOs(i)
.Body = myDraftsFolder.Items.Item(lDraftItem).Body
.Subject = myDraftsFolder.Items.Item(lDraftItem).Subject
.Display
.Save
.Close olPromtForSave
End With
Next
Next lDraftItem

Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing

End Sub

[Paleo]

You could also use this one that does stages 1 AND 2 all together:

Public Sub SepareDrafts()

Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
Dim objMailMessage As Outlook.MailItem
Dim emlBody, sendTo As String
Dim TOs

Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
Set myDraftsFolder = myNameSpace.PickFolder

For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
TOs = Split(myDraftsFolder.Items.Item(lDraftItem).To, ";")
For i = 0 To UBound(TOs)
Set objMailMessage = myOutlook.CreateItem(0)
With objMailMessage
.To = TOs(i)
.Body = myDraftsFolder.Items.Item(lDraftItem).Body
.Subject = myDraftsFolder.Items.Item(lDraftItem).Subject
.Display
.Send
End With
Next
Next lDraftItem
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing

End Sub

[csvaasan]

Hi Paleo,

Due to some hectic works, just today I tried using this code as-it-is and "Select Folder" dialogue box appears and if I select Draft Folder and click OK, nothing happened; Compose window stays without any changes and Draft folder does not have any messages...

Please understand I am not a coder...


You could also use this one that does stages 1 AND 2 all together:

Public Sub SepareDrafts()

Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
Dim objMailMessage As Outlook.MailItem
Dim emlBody, sendTo As String
Dim TOs

Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
Set myDraftsFolder = myNameSpace.PickFolder

For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
TOs = Split(myDraftsFolder.Items.Item(lDraftItem).To, ";")
For i = 0 To UBound(TOs)
Set objMailMessage = myOutlook.CreateItem(0)
With objMailMessage
.To = TOs(i)
.Body = myDraftsFolder.Items.Item(lDraftItem).Body
.Subject = myDraftsFolder.Items.Item(lDraftItem).Subject
.Display
.Send
End With
Next
Next lDraftItem
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing

End Sub

[Paleo]

Hi csvaasan (http://www.vbaexpress.com/forum/member.php?u=46359),

its not intended to change anything on your drafts folder. Check over sent items and you will see the messages have been sent.
It dont clear drafts folder to allow you to use the same message over and over.

[s0s]

Caro Carlos,
nunca fiz nada em VBA, mas agora acho k preciso.
acabei de fazer um mailshot com MailMerge mas ao mandar deu erro e só mandou uns 500/2000.
Os outros 1500 ja n foram, entoa mudei-os pra Drafts.
posso abrir cada um e fazer Send, mas é muito longo.
Vi este Thread sobre mandar tudo o k está nos Draft e gostaria de o aplicar.
Tbm encontrei outro forum k falava o mesmo mas as linhas de programacao eram menos:
Sub SendDrafts()
Dim ns As NameSpace
Dim drafts As MAPIFolder
Dim Item As MailItem

Set ns = Application.GetNamespace("MAPI")
Set drafts = ns.GetDefaultFolder(olFolderDrafts) ' 16
For Each Item In drafts.Items
'Item.Send
Next
End Sub

Para teste criei uma pasta Personal Folders/DTest. Tenho lá 2 emails teste.
e mudei as linhas acima para:
Sub SendDTest()
Dim ns As NameSpace
Dim dtest As MAPIFolder
Dim Item As MailItem

Set ns = Application.GetNamespace("MAPI")
Set dtest = ns.GetDefaultFolder(olFolderDTest) ' 16
For Each Item In dtest.Items
'Item.Send
Next
End Sub

mas diz Run-time error e aponta pra linha do 'Set draft', k mudei pra 'Set dtest'

please, o k esta errado ?
obgo

PS: seria melhor eu escrever isto tudo em ingles pro beneficio dos k consultam este forum ?