[Resolvido]Código Não Está Enviado Anexo

Pessoal Preciso de ajuda, por favor.

Tenho o codigo abaixo, e não está indo os anexos, o que estou fazendo de errado:

Private Sub Comando2_Click()
Dim X As String
Dim rst As DAO.Recordset
Dim strDestinatarios
Dim strTitulo
Dim strMensagemCorpoDoEmail
Dim strEnderecos As String
Dim stremail
Dim StrEnvio
Dim strCaminho As String
Dim strAnexo1 As String, strAnexo2 As String, strAnexo3 As String, ema As String, origem As String
On Error Resume Next

'Atualiza formulario caso sejam alterados os dados
Me.Form.Refresh
Me.Recalc

If DCount("[Selecionado]", "[E_Mails]", "Selecionado = -1") = 0 Then
MsgBox "Não foi selecionado e-mail para o envio" & vbCrLf & _
"Cancelando a operação!", vbCritical, "Atenção"
Exit Sub
Else

If IsNull(Me.Local1.Value) = False Or Me.Local1.Value <> "" Then
strAnexo1 = Me.Local1.Value
Else
strAnexo1 = ""
End If

If IsNull(Me.Local2.Value) = False Or Me.Local2.Value <> "" Then
strAnexo2 = Me.Local2.Value
Else
strAnexo2 = ""
End If

If IsNull(Me.Local3.Value) = False Or Me.Local3.Value <> "" Then
strAnexo3 = Me.Local3.Value
Else
strAnexo3 = ""
End If


If VerificaInternet = 1 Then 'Usa a função que verifica se a internet está conectada
On Error Resume Next

origem = GetPathPart
ema = "Email"

strEnderecos = "SELECT [E_Mails].[Email], [E_Mails].[Selecionado] FROM [E_Mails]" _
& "WHERE Selecionado= -1;"

Set rst = CurrentDb.OpenRecordset(strEnderecos)

Do Until rst.EOF
stremail = strDestinatarios & rst("Email")
strDestinatarios = Left(stremail, Len(stremail)) & ";"


rst.MoveNext
Loop
StrEnvio = Left(strDestinatarios, Len(strDestinatarios) - 1)
strMensagemCorpoDoEmail = Me![Descrição]
[E_Mail] = strDestinatarios
strTitulo = Me.Assunto.Value
With objNewMail
strDestinatarios = Left(strDestinatarios, Len(strDestinatarios) - 1)
stremail = strDestinatarios

.To = strDestinatarios
If IsNull(Me.Local1) = True And IsNull(Me.Local2) = True _
And IsNull(Me.Local3) = True Then

ElseIf IsNull(Me.Local1) = False And IsNull(Me.Local2) = True And IsNull(Me.Local3) = True Then
.Attachments.Add strAnexo1

ElseIf IsNull(Me.Local1) = False And IsNull(Me.Local2) = False And IsNull(Me.Local3) = True Then
.Attachments.Add strAnexo1
.Attachments.Add strAnexo2

ElseIf IsNull(Me.Local1) = False And IsNull(Me.Local2) = False And IsNull(Me.Local3) = False Then
.Attachments.Add strAnexo1
.Attachments.Add strAnexo2
.Attachments.Add strAnexo3
End If
.HTMLBody = fncLerArquivo(fncLocalBD & "\" & strMensagemCorpoDoEmail)
.Display

End With

On Error Resume Next
DoCmd.SendObject , , , StrEnvio, , , strTitulo, strMensagemCorpoDoEmail, True, False
Call OcultaConfigEmail
rst.Close
Set rst = Nothing
End If

End If
End Sub

Desabilite o On Error Resume Next para ver se aparece alguma mensagem de erro. Não é recomendado usar esse argumento enquanto o aplicativo não estiver pronto, pois se ocorrer erros de código, nenhuma mensagem será exibida informando o erro.

Criquio

Tirei o comando que vc falou e não deu mensagem de erro nenhuma e antes também não, segue link do bd.

Baixar BD Marcio

Perdoe-me a intromissão.. Voce retirou este exemplo do fórum?...

Parece-me um que fiz a um membro....

Se for este.. no fórum tem um exemplo mais completo.. inclusive com a gravação da mesnsagem enviada..

Saudações

http://maximoaccess.forumeiros.com/t3189-envio-de-e-mail-com-anexos-usando-form-de-envio-atraves-do-access

Insira estas linhas depois do Me.Recalc (no inicio)


Call InitializeOutlook
Set objNewMail = gOLApp.CreateItem(olMailItem)


Não necessita de vereficar se tem anexo ou não, delete os If`s e deixe apenas assim


With objNewMail

strDestinatarios = Left(strDestinatarios, Len(strDestinatarios) - 1)
stremail = strDestinatarios

.To = strDestinatarios
.subject = strTitulo
.body = strMensagemCorpoDoEmail
.Attachments.Add strAnexo1
.Attachments.Add strAnexo2
.Attachments.Add strAnexo3
.Display

End With

Delete tambem estas duas linhas:


'On Error Resume Next
'DoCmd.SendObject , , , StrEnvio, , , strTitulo, strMensagemCorpoDoEmail, True, False

Não desfazendo o do Harysohn

este tambem está fabuloso

http://maximoaccess.forumeiros.com/t386-envia-email-com-2-anexos

FUNCIONOU PERFEITAMENTE

MUITO OBRIGADO

Faltou o resolvido no tópico amigão...

Saudações

Pois é, faltou e já lá está.