Olá amigos de fórum, Estou tentando automatizar o envio de emails do Outlook.
Tenho uma planilha que ao invés de enviar os emails diretamente (.Send para evitar AVISO de segurança), eu uso .Save (salva as mensagens no rascunho)
Dai fiz um módulo no Outlook com o seguinte código:
Public Sub EnviaEmailDoRascunho()
On Error GoTo CancelaEnvio
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
.Send
End With
Next
Next lDraftItem
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
MsgBox "Mensagens enviadas com sucesso.", vbInformation, "CONFIRMAÇÃO"
Exit Sub
CancelaEnvio:
MsgBox "Ação cancelada pelo usuário.", vbExclamation, "CANCELADO"
End Sub
Essa rotina apenas envia os emails, não exlcuindo os rascunhos após o envio.
Procurando na internet, encontrei uma rotina que deleta emails, porém, somente se forem selecionados com o mouse.
Sub DeleteSelectedEmails()
Dim myOlApp, myNameSpace, Sel, objRecip As Object
Dim MyItem As Outlook.MailItem
Dim DeletedFolder As Object
Dim objProperty As Object
Dim SavedEntryId, I
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set Sel = Application.ActiveExplorer.Selection
For I = 1 To Sel.Count
If Sel.Item(I).Class = olMail Then
Set MyItem = Sel.Item(I)
MyItem.UserProperties.Add "DeleteMeNow", olText
MyItem.Save
MyItem.Delete ' Places message in the Deleted Items folder
End If
Next
Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
For Each MyItem In DeletedFolder.Items
Set objProperty = MyItem.UserProperties.Find("DeleteMeNow")
If TypeName(objProperty) <> "Nothing" Then
MyItem.Delete
End If
Next
End Sub
É possível adaptar esse segundo código para que ele delete sempre os emails dos rascunhos?
Resumindo, preciso de alguma rotina para excluir todos os meus rascunhos no Outlook.
Postado : 09/09/2014 12:41 pm