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

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

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.

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.

Resolvido. Muito Obrigado