[Resolvido]Enviar e-mail para todos os contatos.

Bom dia,

Prezados, estou com problema, fiz um formulário que envia e-mail com um texto padrão, mas ele não está puxando todos os contatos.

Desde já o meu muito obrigado.

Segue comando:

Private Sub Form_Load()

Dim strArquivo As String
Dim strLocal As String
Dim objOut As Object
Dim objmail As Object

Const olMailItem = 0
Const olByValue = 1

Set objOut = CreateObject("Outlook.application")

Set objmail = objOut.CreateItem(olMailItem)

objmail.Subject = "DAT: " & Me.Código & " - Termo de Compromisso"
objmail.Body = "Prezado, o Termo de Compromisso está vencido, aguardamos a entrega do Manifesto de Carga para finalizarmos o processo."
objmail.To = Me!email & ", "


objmail.Display



Set objmail = Nothing
Set objOut = Nothing

End Sub


Achei a solução: https://www.maximoaccess.com/t227-enviar-e-mail-pelo-access

eu uso um metodo do mail CDO que nele vc usa o proprio access para envio sem a necessidade do outlook.
Vc tera que criar uma função do tipo privada dentro do formulario para fazer o envio e abrir um recordset para pegar o email para quem queira mandar.
Tipo uma tabela email
Tipo aqui essa e uma função que eu uso para poder enviar os emails.
Private Function Enviar_Fichas()
Dim mens As Object
Dim Config As Object
Set mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")

With Config

.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("[smtpserver]", "Temp_Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("[smtpserverport]", "Temp_Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = DLookup("[sendusing]", "Temp_Empresa")

If DLookup("[smtpauthenticate]", "Temp_Empresa") = 1 Then
       .Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
  Else
       .Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
  End If
 
  If DLookup("[smtpuessl]", "Temp_Empresa") = -1 Then
       .Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
  Else
       .Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
  End If
 
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = DLookup("[sendusername]", "Temp_Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("[sendpassword]", "Temp_Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = DLookup("[smtpconnectiontimeout]", "Temp_Empresa")

If DLookup("[smtpuessl]", "Temp_Empresa") = -1 Then
       .Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
  Else
       .Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
  End If
 
  .Fields.Update
End With

Set mens = New CDO.Message
With mens
Set .Configuration = Config
.From = "Lotus Email de Serviços"

.Sender = DLookup("[Email]", "Temp_Empresa")

.Subject = "Ficha(s) de Encaminhamentos"

.TextBody = "Segue em Anexo Fichas de Encaminhamento. " & vbCrLf _
& vbCrLf _
& "Empresa: " & DLookup("[razaosocial]", "Temp_Empresa") & vbCrLf _
& "Telefone: " & DLookup("[Telefone1]", "Temp_Empresa") & vbCrLf _
& "Endereço: " & DLookup("[Endereco]", "Temp_Empresa") & vbCrLf _
& "Cidade: " & DLookup("[Cidade]", "Temp_Empresa") & "--" & DLookup("[uf]", "Temp_Empresa") & vbCrLf _
& "Site: " & DLookup("[site]", "Temp_Empresa") & vbCrLf _
& "Email: " & DLookup("[email]", "Temp_Empresa") & vbCrLf _
& vbCrLf _
& "OBS: Não Retorne Este Email " & vbCrLf _

.To = Email_Cli
'a linha abaixo pega o pdf criado e anexa à mensagem
.AddAttachment CurrentProject.Path & "\PDFs\" & strarquivo

.Send
End With

Set mens = Nothing
Set Config = Nothing

Kill strPath

DoCmd.Hourglass False
 
'Sleep 500
  nReg1 = nReg1 + 1
   rst.MoveNext    'vai para o proximo registro

rst.Close    'fecha o recorset
MsgBox "Email Enviado com Sucesso.", vbInformation, Titulo

Exit Function
End Function




e Essa aqui eu uso para chamar esta ai e passar os valores que eu quero pegar da tabela.

Private Sub BTENVIAR_Click()

If DCount("*", "Qry_Ficha_Enc") = 0 Then
MsgBox "Não a Ficha a Imprimir", vbCritical, Titulo
Exit Sub
End If


If Me.CBXCLIENTE.Column(2) = "" Then
MsgBox "Este Cliente Não tem Email Cadastrado."

Email_Cli = InputBox("Entre com Email que Deseja Enviar", Titulo)

Else
Email_Cli = Me.CBXCLIENTE.Column(2)

End If

Call VerificaInternet

If VerificaInternet = 0 Then
MsgBox "Não há Conexão com a Internet." & vbCr & "Verifique sua conexão com a internet.", vbCritical, Titulo
Exit Sub
End If

If MsgBox("Deseja Enviar as Ficha de Encaminhamento" & vbCr & _
          "Cliente: " & Me.CBXCLIENTE.Column(1) & vbCr & _
          "Email: " & Me.CBXCLIENTE.Column(2) & vbCr & _
          "", vbYesNo, Titulo) = vbYes Then
'DoCmd.OpenForm "frmProgresso"

DoEvents
Call Gerar_Fichas
DoEvents
Call Enviar_Fichas
DoEvents


End If

End Sub

esta função ela envia o relatorio que e gerado ja no formato pdf e anexa o pdf no email e envia.

mais qualquer coisa posta parte do seu projeto que fica melhor para nos entender.