[Resolvido]Envio de e-mail por formulario filtrado

Boa noite;

Consegui por meio de voces um código para o envio de e-mails pelo Outlook, de acordo com registros do access, testei e funcionou muito bem. Mas resolvi alterar a metodologia, criando um formulario continuo com permissões de filtros sequenciais do menu suspenso do access, onde poderia filtrar por genero, bairro, cidade ou qualquer outro filtro disponivel nesse formulario. Bem, eu quero adaptar o código para que ele reconheça esse filtro, ja que quando eu filtro os registros no formulario e aperto o botao para enviar os e-mails, ele busca todos os registros da consulta, e não respeita os filtros aplicados. O codigo segue abaixo

Código:


Private Sub BtBairro_Click()
'Sub SendMessages(Optional AttachmentPath)

Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim TheAddress As String

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("SELECT * FROM ConsultaEleitorado")

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = ""

Do Until MyRS.EOF
    If TheAddress = "" Then
        TheAddress = MyRS![Email]
    Else
        TheAddress = TheAddress & "; " & MyRS![Email]
    End If
    MyRS.MoveNext
Loop

With objOutlookMsg
' Add the CCo recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo

' Add the Cc recipients to the e-mail message.
If (IsNull(Forms!Email!Email)) Then
' Else
' Set objOutlookRecip = .Recipients.Add(Forms!Email!Email)
' objOutlookRecip.Type = olCC
End If

' Set the Subject, the Body, and the Importance of the e-mail message.
'.Subject = Forms!EMail!Subject
'.Body = Forms!frmMail!MainText
'.Importance = olImportanceHigh 'High importance

'Add the attachment to the e-mail message.
' If Not IsMissing(AttachmentPath) Then
' Set objOutlookAttach = .Attachments.Add(AttachmentPath)
' End If

' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Display
End With

Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub


Podem me ajudar?
Obrigado

Depois de filtrado o subform voce vai carregar o recordsource do mesmo ao inves da tabela, algo assim:

Dim StrSql as String

StrSql = Me.RecordSorce
ou
StrSql = Forms!NomeDoForm.NomeSubForm!Form.RecordSource

Set MyRS = MyDB.OpenRecordset(StrSql)

Cumprimentos.

Amigo Piloto;

Desculpe, mas nao consegui adaptar esse codigo que voce passou ao meu. Poderia adaptar seu exemplo na linha do meu codigo pra que eu entenda? Desculpe pelo abuso de sua boa vontade, eu realmente tentei e não consegui amigo.

Um abraço

Leonardo

Poste o seu bd para que possamos fazer isso.

Cumprimentos.

Segue o arquivo.

Obrigado

Converta em 2007 e reenvie por gentileza

Cumpimentos.

Amigo Piloto

O arquivo ja está no formato 20017/2010, e se converto para 2003 ele perde as funcionalidades. Tem alguma sugestão quanto a isso?

Obrigado

Amigo converta assim mesmo e me mande... so vou encontrar a solução e posto a mesma e voce aplica no teu

Cumprimentos.

Piloto, eu tentei mesmo fazer isso

O fato é que meu access 2010 me da a mensagem falando sobre o erro e não converte o arquivo.

Desculpe a canseira meu camarada...

Leo

Crie uma copia... exclua tudo que nao interessa a soluçao e converta..

Deixe apenas o form e tabela que e necessario a sulução.

Piloto,

Estou enviando o arquivo, montei outro banco de dados no formato que vc solicitou pq o meu banco original nao converte de jeito nenhum. Montei uma tabela e um formulario no arquivo que estou enviando mas o codigo não funfa de jeito nenhum agora. De qualquer forma, estou enviando pra vc, ok?

Um abraço, muito obrigado pela ajuda

Leo

Teste:

Private Sub Enviar_Click()
'Sub SendMessages(Optional AttachmentPath)

Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim TheAddress As String
Dim StrSQL
Set MyDB = CurrentDb

SreSQL = Me.RecordsetClone
Set MyRS = MyDB.OpenRecordset(SrrSQl)

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = ""

Do Until MyRS.EOF
    If TheAddress = "" Then
        TheAddress = MyRS![Email]
    Else
        TheAddress = TheAddress & "; " & MyRS![Email]
    End If
    MyRS.MoveNext
Loop

With objOutlookMsg
' Add the CCo recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo

' Add the Cc recipients to the e-mail message.
If (IsNull(Forms!Email!Email)) Then
' Else
' Set objOutlookRecip = .Recipients.Add(Forms!Email!Email)
' objOutlookRecip.Type = olCC
End If

' Set the Subject, the Body, and the Importance of the e-mail message.
'.Subject = Forms!EMail!Subject
'.Body = Forms!frmMail!MainText
'.Importance = olImportanceHigh 'High importance

'Add the attachment to the e-mail message.
' If Not IsMissing(AttachmentPath) Then
' Set objOutlookAttach = .Attachments.Add(AttachmentPath)
' End If

' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Display
End With

Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub

Ta dando um erro nessa linha:

Set MyRS = MyDB.OpenRecordset(SrrSQl)

Não sei se foi algum erro de digitação essa SrrSQL, eu rodei ele dessa forma e depois modifiquei para StrSQL, mas ta dando a mensagem

Erro de execução 3001
Argumento Invalido

Obrigado

Ei-lo

Puxa Piloto,

Ja estou até envergonhado por te perturbar tanto, funcionou buscando o Outlook como anteriormente, mas tambem continua trazendo todos os registros da tabela, mesmo com o formulario filtrado.

Te agradeço pelo esforço em me ajudar, um grande abraço

Leo

Estamos aqui pra isso, não se preocupe.

Private Sub Enviar_Click()
'Sub SendMessages(Optional AttachmentPath)

Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim TheAddress As String
Dim StrSQL
Set MyDB = CurrentDb

Set MyRS = Me.RecordsetClone
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = ""

Do Until MyRS.EOF
    If TheAddress = "" Then
        TheAddress = MyRS![Email]
    Else
        TheAddress = TheAddress & "; " & MyRS![Email]
    End If
    MyRS.MoveNext
Loop

With objOutlookMsg
' Add the CCo recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo

' Add the Cc recipients to the e-mail message.
If (IsNull(Forms!Email!Email)) Then
' Else
' Set objOutlookRecip = .Recipients.Add(Forms!Email!Email)
' objOutlookRecip.Type = olCC
End If

' Set the Subject, the Body, and the Importance of the e-mail message.
'.Subject = Forms!EMail!Subject
'.Body = Forms!frmMail!MainText
'.Importance = olImportanceHigh 'High importance

'Add the attachment to the e-mail message.
' If Not IsMissing(AttachmentPath) Then
' Set objOutlookAttach = .Attachments.Add(AttachmentPath)
' End If

' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Display
End With

Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub

Cumprimentos.

Piloto,

Juro que te pagaria uma cerveja se te visse pessoalmente amigo, agora sim funcionou perfeitamente.

Muito obrigado

Leo

Poderia ser um refrigerante?

O Fórum agradece o Retorno.