Estou utilizando um código feito pelo chstream que funciona perfeitamente, sem erro algum. A partir de um formulário com um subform, ele gera um email com os campos selecionados do subform e envia para o email do registro selecionado. Até aí, ótimo, ótimo...! Funciona tudo duma forma mais que perfeita, sem precisar digitar uma linha e enviar para os destinatários só na base do clique.
Só que os registros estão aumentando e a necessidade de enviar mais e mais e-mails idem. O que me foi solicitado agora é que haja uma caixa de combinação que selecionasse os registros e enviasse para cada um deles um e-mail personalizado através do próprio Outlook, seguindo este mesmo código abaixo. Encontrei um exemplo no repositório, mas ele só envia e-mails padrão e para vários destinatários no mesmo e-mail, o que não é o caso.
Alguém poderia me dar uma luz nesse sentido? Segue o código, com os créditos do chsestrem.
'Exemplo para envio de email em forma de Tabela
'By Charles Sestrem
'chsestrem@hotmail.com
'05 de Agosto de 2011
' na declaração Geral
Private Sub SolicitarMaterial_Click()
Dim StrDestinatario
Dim StrNomeDest As String
Dim stDocName As String
Dim StrMensagem As String
Dim StImage As String
Dim OutApp As Object
Dim OutMail As Object
Dim rs As DAO.Recordset
Dim strSQL As String
Dim txthtm As String
If fncOutlookInstalado = False Then
MsgBox "O Outlook não está instalado.", vbInformation, "Aviso"
Exit Sub
Else
If fncOutlookAberto = False Then
MsgBox "Mantenha o Outlook aberto para ser possível o envio do email.", vbInformation, "Aviso"
Exit Sub
'ou force a abertura do outlook
'Call Shell("outlook.exe", vbMinimizedNoFocus)
End If
End If
'Exportar uma tabela Access diretamente para o Corpo do Email
txthtm = "<HTML> "
txthtm = txthtm & "<HEAD>"
txthtm = txthtm & "<TITLE>Criando Tabelas</TITLE>"
txthtm = txthtm & "</HEAD>"
txthtm = txthtm & "<BODY>"
txthtm = txthtm & "<table width=200 border=0 cellspacing=0 cellpadding=0><tr><td><img src=http://www.site.com.br/email/email.jpg width=589 height=117 /></a></td>"
txthtm = txthtm & "</tr><tr><td><strong><font color=#555555 font size=2 face=Verdana>Assunto: Contrato</font></strong></td>"
txthtm = txthtm & "</tr><tr><td><strong><font color=#555555 font size=2 face=Verdana>Cliente: " & [RAZAO] & "</font></strong></td>"
txthtm = txthtm & "</tr><tr><td><strong><font color=#555555 font size=2 face=Verdana>Contrato: " & [nCONTRATO] & "</font></strong></td>"
txthtm = txthtm & "<p>"
txthtm = txthtm & "</tr><tr><td> </td></tr><tr><td><strong><font color=#555555 font size=2 face=Verdana>Prezado(a) Sr.(a) " & [AUTORIZANTE] & "</font></strong></td>"
txthtm = txthtm & "<p>"
txthtm = txthtm & "</tr><tr><td> </td></tr><tr><td><font color=#555555 font size=2 face=Verdana>Segue abaixo as especificações de seu contrato:<br></font></font></td>"
txthtm = txthtm & "<p>"
txthtm = txthtm & "<BR>"
txthtm = txthtm & "<p><table width=600 TABLE BORDER=1> "
txthtm = txthtm & "<TR bgcolor= ""#CFCFCF""><CENTER><TD><strong><font color=#555555 font size=1 face=Verdana>CAMPO1</font></strong></TD><TD><strong><font color=#555555 font size=1 face=Verdana>CAMPO2</font></strong></TD><TD><strong><font color=#555555 font size=1 face=Verdana>CAMPO3</font></strong></TD>"
txthtm = txthtm & "<TD><strong><font color=#555555 font size=1 face=Verdana>CAMPO4</font></strong></TD><TD><strong><font color=#555555 font size=1 face=Verdana>CAMPO5</font></strong></TD></CENTER></TR>"
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_contratos_fechados WHERE nCONTRATO='" & Me.nCONTRATO & "';")
' Inicia o loop para exibir todos os registros
Do While Not rs.EOF
txthtm = txthtm & "<TR><! Cria a primeira linha da tabela>"
txthtm = txthtm & "<TD width=100><font color=#555555 font size=1 face=Verdana>" & rs!CAMPO1 & " </font></TD>"
txthtm = txthtm & "<TD width=70><font color=#555555 font size=1 face=Verdana>" & rs!CAMPO2 & " </font></TD>"
txthtm = txthtm & "<TD width=150><font color=#555555 font size=1 face=Verdana>" & rs!CAMPO3 & " </font></TD>"
txthtm = txthtm & "<TD width=130><font color=#555555 font size=1 face=Verdana>" & rs!CAMPO4 & " </font></TD>"
txthtm = txthtm & "<TD width=100><font color=#555555 font size=1 face=Verdana>" & rs!CAMPO5 & "</font></TD></TR>"
rs.MoveNext
Loop
txthtm = txthtm & "</TABLE>"
txthtm = txthtm & "</BODY>"
txthtm = txthtm & "</HTML>"
txthtm = txthtm & " <p><font color=#555555 font size=2 face=Verdana>Atenciosamente,</font></p>"
txthtm = txthtm & " <p><strong><font color=#555555 font size=2 face=Verdana>" & Me.txtUser & "</font></strong><br />"
txthtm = txthtm & " <strong><font color=#555555 font size=2 face=Verdana>Nome da Empresa</font></strong><br />"
txthtm = txthtm & " <font color=#555555 font size=2 face=Verdana>(21) 3555-2541</font><br />"
txthtm = txthtm & "<font color=#555555 font size=2 face=Verdana>email@email.com.br</font><br>"
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "" & [EMAIL] & ""
.Subject = " - Ct. " & [nCONTRATO] & " - " & [FANTASIA]
.htmlbody = txthtm ' Corpo do Email
.display
End With
rs.Close
End Sub