MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

3 participantes

    Preencher Destinatário, Assunto, Corpo do E-mail Outlook

    avatar
    cmedeiros
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 44
    Registrado : 29/05/2016

    Preencher Destinatário, Assunto, Corpo do E-mail Outlook Empty Preencher Destinatário, Assunto, Corpo do E-mail Outlook

    Mensagem  cmedeiros 8/9/2022, 15:29

    Senhores (as), bom dia

    Mas uma vez peço ajuda para uma questão.

    Estou tentar automatizar o envio de e-mail pelo Outlook.

    Consegui em um fórum o código abaixo que praticamente resolve, porém faltaram algumas coisas para automatizar que não estou conseguindo. Que seria o preenchimento automático do destinatário, assunto e mensagem no corpo do e-mail.

    De forma antecipada já agradeço a todos.

    Segue código:

    Dim strArquivo As String
    Dim strLocal As String
    Dim objOut As Object
    Dim objmail As Object
    Dim objAnexo As Object
    Const olMailItem = 0
    Const olByValue = 1
    '---------------------------------------------
    'Carregando a coleção do Outlook
    'Similar ao abrir o Outlook
    '---------------------------------------------
    Set objOut = CreateObject("Outlook.application")

    '------------------------------------------------------------
    'Abrindo o formulário de email para inserir os itens de email
    'Similar ao clicar no botão NOVO do Outlook
    '------------------------------------------------------------
    Set objmail = objOut.CreateItem(olMailItem)

    '------------------------------------------------------------
    'Abrindo a opção anexo
    'Similar ao clicar no botão ANEXO do Outlook
    '------------------------------------------------------------
    Set objAnexo = objmail.Attachments

    '------------------------------------------------------------------------------
    'Indico o nome do arquivo pdf e o local que será gravado.
    'Neste exemplo gero os nomes dos arquivos, aproveitando o número da proposta,
    'ficando com o seguinte aspecto: proposta1.pdf, proposta2.pdf,...
    '------------------------------------------------------------------------------
    strArquivo = "Cotação" & Me!iDCotacao & ".pdf"
    strLocal = CurrentProject.Path & "\enviadas\" & strArquivo

    '----------------------------------------------------------------------------
    'Abre o relatório filtrado e oculto, de acordo com a proposta selecionada.
    '----------------------------------------------------------------------------
    DoCmd.OpenReport "rptCotacaoPrecos", acViewPreview, , "iDCotacao=" & Me!iDCotacao, acHidden
    "Me.msgPadrao", 0
    '----------------------------------------------------------------------------
    'Gera 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.
    '----------------------------------------------------------------------------
    DoCmd.OutputTo acOutputReport, "rptCotacaoPrecos", acFormatPDF, strLocal, True

    '---------------------------------------------
    'Fecha o relatório que está oculto
    '---------------------------------------------
    DoCmd.Close acReport, "rptCotacaoPrecos"

    '-------------------------------------------------------------
    'Adiciona o arquivo pdf no anexo, capturado da pasta enviados
    '-------------------------------------------------------------
    objAnexo.Add strLocal, olByValue, 1

    '--------------------------------------------------------
    'Mostra o formulário de envio de email
    '--------------------------------------------------------
    objmail.Display

    '-------------------------------------------------------
    'Tudo já foi entregue ao Outlook; então podemos esvaziar
    'a memória do computador usada pelas variáveis objeto.
    '-------------------------------------------------------
    Set objAnexo = Nothing
    Set objmail = Nothing
    Set objOut = Nothing
    avatar
    Nangell
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 6
    Registrado : 12/09/2022

    Preencher Destinatário, Assunto, Corpo do E-mail Outlook Empty Inserir destinatários, assunto e anexo em um e-mail do outlook

    Mensagem  Nangell 12/9/2022, 11:38

    Bom dia Medeiros,
    Tente o seguinte:

    Dim strArquivo As String
    Dim strLocal As String
    Dim objOut As Object
    Dim objmail As Object
    Dim objAnexo As Object
    Const olMailItem = 0
    Const olByValue = 1
    '---------------------------------------------
    'Carregando a coleção do Outlook
    'Similar ao abrir o Outlook
    '---------------------------------------------
    Set objOut = CreateObject("Outlook.application")

    '------------------------------------------------------------
    'Abrindo o formulário de email para inserir os itens de email
    'Similar ao clicar no botão NOVO do Outlook
    '------------------------------------------------------------
    Set objmail = objOut.CreateItem(olMailItem)

    objmail.display

    With objmail

    .To = "E-mail destino" 'Aqui entra o e-mail destino, equivalente ao campo para
    .CC = "E-mail destino cópia" 'Aqui entra o e-mail destino cópia, equivalente ao campo CC

    .BCC = "E-mail destino oculto" 'Aqui entra o e-mail destino oculto, equivalente ao campo CCo | Os e-mails colocados aqui, não são visíveis para outras pessoas que receberão o e-mail


    .Subject = "Este é o campo assunto" 'Aqui entra o assunto do email

    .Attachments.Add "Caminho Anexo" 'Aqui entra o caminho do anexo do e-mail, se for o caso

    End With


    só coloquei o início do código aqui, mas é o suficiente para você saber o que fazer

    Espero ter ajudado, caso a resposta tenha sido útil, por favor marque como respondida.
    marcelo3092
    marcelo3092
    Avançado
    Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 277
    Registrado : 19/08/2010

    Preencher Destinatário, Assunto, Corpo do E-mail Outlook Empty Re: Preencher Destinatário, Assunto, Corpo do E-mail Outlook

    Mensagem  marcelo3092 14/9/2022, 01:09

    Boa noite seguinte eu uso um tb espero ajudar ele manda ate um relatorio em pdf como anexo no email tudo atravez do access sem usar o outlook.
    so tem que ativar a referencia Microsoft CDO for windows 2000 libary.

    Private Function Enviar_Fichas()
    On Error GoTo trata_erro

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

    With Config

    ' Aqui ele faz um dlookup na tabela Temp_Empresa e pega o valor de cada campo para ser passada.
    .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 = "Curriculo de Candidatos"

    'aqui e o corpo da mensagem

    .TextBody = "Segue em Anexo Curriculo de Candidatos. " & 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 _
    & "Mensagem Adicional: " & Me.txtmensagem & vbCrLf _
    & vbCrLf _
    & "OBS: Não Retorne Este Email " & vbCrLf _

    ' aqui o endereço para quem vai ser enviada.
    .To = Me.CBXCLIENTE.Column(2)

    '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

    'MsgBox "Email Enviado com Sucesso.", vbInformation, Titulo

    trata_erro:
    If Err.Number = -2147220975 Then
    MsgBox "O Servidor Bloqueou Este Email, Sera Enviado Via Outlook.", vbCritical, Titulo

    DoEvents
    'Call Enviar_Outlook
    'DoEvents

    Exit Function

    End If

    'DoCmd.OpenForm "frmFinalizar"
    'DoCmd.OpenReport "Carta_Encaminhamento", acViewPreview, , idCandidato = (rst("idcandidato").Value)
    'Call deleta("tblencaminhamento where idencaminhamento=" & idd)

    End Function

    espero ter ajudado.


      Data/hora atual: 25/9/2022, 14:27