[Resolvido]Enviar e-mail CDO. com anexo com origem em registro em uma tabela do sistema

Olá,

Mais uma vez peço a ajuda de todos. O código abaixo serve para enviar um e-mail via CDO com anexo. Quando eu informo em uma variável a origem do arquivo que será anexado e defino a variável como string, ele funciona muito bem. O arquivo é enviado.

Entretanto, agora, este botão está em um formulário, e este formulário baseado em uma tabela. Esta tabela possui um campo do tipo anexo. Quero enviar este anexo que está baseado em uma tabela, que está no formulário.

O anexo está sendo enviado, mas como "Anexo sem título.dat". Alguém sabe como enviar o anexo baseado em uma tabela, e não baseado em um diretório no sistema?

--------------------------------------------

Código:



Private Sub Comando1_Click()

On Error GoTo erromail


Dim Mens As CDO.Message
Dim Config As CDO.Configuration
Set Mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")


With Config

.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "email-ssl.com.br"
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "pipelab@instrulab.com.br"
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "XX"
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Fields.Update

End With

Set Mens = New CDO.Message
With Mens
Set .Configuration = Config
.from = """Ernando | Instrulab Equipamentos e Serviços"" <pipelab@instrulab.com.br>"
.Sender = "ernando.custodio@instrulab.com.br"
.CC = "ernando.custodio@instrulab.com.br"
.BodyPart.Charset = "utf-8"
.subject = "Seja bem-vindo a Instrulab: Equipamentos e serviços para Laboratórios"
.HTMLBody = ""
.To = "ernando.custodio@instrulab.com.br"
.AddAttachment (Me.Anexo)
.Send

End With

Set Mens = Nothing
Set Config = Nothing


erromail:
If Err.Number = 13 Then
   Resume Next
ElseIf Err.Number = -2147220979 Then

   MsgBox "Você inseriu um endereço de email inválido ou inexistente." & vbCrLf & "Verifique o email e tente novamente.", vbOKOnly + vbCritical, "Email inválido"

Else
   Resume Next
End If

Olá;

Só não estou a entender se o seu campo na tabela é tipo anexo mesmo.

É tipo anexo ou texto ?

Bom dia, Paulo

O tipo do campo é anexo.

Ok;

Sendo anexo, não funciona como esperado.

Há tempos coloquei aqui um exemplo de exportar anexos, vou ver se encontro.

A solução é você exportar o anexo, e depois anexar ao email.

Aguarde...

O exemplo é este:

https://www.maximoaccess.com/t33634-exportar-anexos-de-uma-tabela

Diga-me por favor qual o nome da sua tabela onde está esse campo Anexo e o nome do campo.

Altere para os nomes corretos da sua tabela e campo anexo;

Teste e retorne por favor.

Código:

Private Sub Comando1_Click()
'By JPaulo maximoaccess
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim rstAnexos As DAO.Recordset
    Dim strCaminho As String
    Dim Mens As CDO.Message
    Dim Config As CDO.Configuration
    
On Error GoTo erromail

strCaminho = ""
     Set dbs = CurrentDb
     'abre o recordset á tabela filtrando pelo nome do anexo
     Set rst = dbs.OpenRecordset("SELECT * FROM SuaTabela WHERE SeuCampoAnexo='" & Me.SeuCampoAnexo & "'")
'se não existirem registros morre aqui
    If rst.RecordCount = 0 Then Exit Sub
    
With rst
'inicia o loop á tabela
Do Until .EOF
'seta a variavel rstAnexos com o nome do anexo na tabela
    Set rstAnexos = rst.Fields("SeuCampoAnexo").Value
    While Not rstAnexos.EOF
'salva o anexo junto do banco
'eliminamos a mensagem de erro se já existir o ficheiro
On Error Resume Next
     rstAnexos.Fields("FileData").SaveToFile CurrentProject.Path & "\"
'escrevo na variavel o caminho do anexo, para usar no email
     strCaminho = CurrentProject.Path & "\" & Me.Anexo_FileName
'avança para novo registro se existir
     rstAnexos.MoveNext
    Wend
   .MoveNext
Loop
End With
'fecha o recordset e limpa a memoria
rst.Close: Set rst = Nothing
'fecha o database e limpa a memoria
dbs.Close: Set dbs = Nothing

Set Mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")

With Config

.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "email-ssl.com.br"
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "pipelab@instrulab.com.br"
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "XX"
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Fields.Update

End With

Set Mens = New CDO.Message

With Mens
Set .Configuration = Config
    .From = """Ernando | Instrulab Equipamentos e Serviços"" <pipelab@instrulab.com.br>"
    .Sender = "ernando.custodio@instrulab.com.br"
    .CC = "ernando.custodio@instrulab.com.br"
    .BodyPart.Charset = "utf-8"
    .Subject = "Seja bem-vindo a Instrulab: Equipamentos e serviços para Laboratórios"
    .HTMLBody = ""
    .To = "ernando.custodio@instrulab.com.br"

'adicionamos o anexo exportado
    If Nz(strCaminho, "") <> "" Then .AddAttachment ("file://" & strCaminho)
    
'se não funcionar, comente a linha de cima e teste assim;
'    If Nz(strCaminho, "") <> "" Then .AddAttachment strCaminho

    .Send
End With

Set Mens = Nothing
Set Config = Nothing

'deletamos o anexo exportado
Kill strCaminho

erromail:
If Err.Number = 13 Then
   Resume Next
ElseIf Err.Number = -2147220979 Then

   MsgBox "Você inseriu um endereço de email inválido ou inexistente." & vbCrLf & "Verifique o email e tente novamente.", vbOKOnly + vbCritical, "Email inválido"

Else
   Resume Next
End If
End Sub

Perfeito, Paulo. Funcionou perfeitamente. Muito obrigado.

Fico feliz
Obrigado pelo retorno o fórum agradece.