marcelo3092 8/5/2020, 00:16
Faz por modo envio CDO dentro do access sem a necessidade do outlook, esse é o codigo que uso
Private Function fncemail()
On Error GoTo trata_erro
Dim strarquivo As String
Dim strlocal As String
Dim strPath As String
strarquivo = "Relatório.pdf"
strlocal = CurrentProject.Path & "\Temp\" & strarquivo
strPath = CurrentProject.Path & "\Temp\" & strarquivo
'Salvando alterações no registro
If Me.Dirty Then DoCmd.RunCommand acCmdSaveRecord
'----------------------------------------------------------------------------
'Abre o relatório filtrado e oculto.
'----------------------------------------------------------------------------
DoEvents
DoCmd.OpenReport "Nome_do_seu_relatorio", acViewPreview, , , acHidden
'----------------------------------------------------------------------------------------
'gero o pdf do relatório através do comando outputto.
'o mecanismo do Access reconhece que o relatório solicitado pelo outputto já está aberto
'e então o outputto usará o relatório já aberto e filtrado.
'-----------------------------------------------------------------------------------------
DoEvents
DoCmd.OutputTo acOutputReport, "Nome_do_seu_relatorio", acFormatPDF, strlocal
DoEvents
'-------------------------------------------
'fecha o relatório clientes que está oculto
'-------------------------------------------
DoCmd.Close acReport, "Nome_do_seu_relatorio"
DoEvents
'---FAZ O ENVIO DO EMAIL--------------
Dim Mens As Object
Dim Config As Object
Set Mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")
'Aqui pega os dados do servidor de uma tabela.
With Config
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("[smtpserver]", "tblempresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("[smtpserverport]", "tblempresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = DLookup("[sendusing]", "tblempresa")
If DLookup("[smtpauthenticate]", "tblempresa") = 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]", "tblempresa") = -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]", "tblempresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("[sendpassword]", "tblempresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = DLookup("[smtpconnectiontimeout]", "tblempresa")
If DLookup("[smtpuessl]", "tblempresa") = -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 = "Relatório"
.Sender = DLookup("[Email]", "tblempresa")
.Subject = "Relatório e Fechamento"
'Aqui e o Cabeçalho do email.
.TextBody = "Segue em Anexo Relação de Vouchers. " & vbCrLf _
& vbCrLf _
& "Linha1" & vbCrLf _
& "Linha2" & vbCrLf _
& "Linha3" & vbCrLf _
& "Linha4" & vbCrLf _
& "Linha5" & vbCrLf _
& "Linha6" & vbCrLf _
& vbCrLf _
& "- " & vbCrLf _
'Email a enviar relatorio temp e a pasta que tem que ter dentro da pasta do sistema para ele criar o pdf nela.
.To = Me.txtemail
' a linha abaixo pega o pdf criado e anexa à mensagem
.AddAttachment CurrentProject.Path & "\temp\" & strarquivo
.Send
End With
Set Mens = Nothing
Set Config = Nothing
Do Until Dir(CurrentProject.Path & "\temp\" & "*") = ""
VBA.Kill (CurrentProject.Path & "\temp\" & "*") 'Excluir arquivo com a extensão escolhida
Loop
trata_erro:
If 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, Titulo
DoCmd.Close acForm, "FrmEnviandoEmail"
Exit Function
Me.txtemail.SetFocus
ElseIf Err.Number = -2147220975 Then
MsgBox "O Servidor Bloqueou o Login." & vbCrLf & "Verifique Sua Configuração de apps seguros e ative a opção menos seguro.", vbOKOnly + vbCritical, Titulo
Exit Function
End If
End Function
Detalhe a referencia Microsoft CDO for Windows 2000 Library tem que tar ativada
e o servidor que mais funciona e o gmail.
e dentro do gmail na sua conta tem uma opção que tb ele bloqueia o acesso
a opção Acesso a app menos seguro na aba segurança da sua conta tem que estar ativada para que ele nao bloqueia.
e as configurações de email tem no gmail basta procura no googel
servidor smtp.
espero que te ajude.
uso essa rotina em varios sistemas meu.
Início
