Pessoal, Boa Noite! preciso de uma ajuda com esse código que vou postar, eu preciso do seguinte: Enviar um e-mail de cada vez e com anexos diferentes. Esse programa ele esta pegando de uma tabela no excel os e-mails e os endereços dos anexos, a estrutura da tabela é basicamente a seguinte.
Enviado? Endereços Anexos
Sim/Não Teste@teste.com C:\teste\testes
Sim/Não Tentar@teste.com C:\teste\Tentar
São arquivos diferentes para pessoas diferentes, só que esse código que eu tenho ele está enviando todos os e-mails de uma vez e não esta aceitando outros anexos, podem me ajudar a corrigir esse erro? a idéia é que o sistema envie um e-mail para cada pessoa da coluna endereços com seus respectivos anexos na coluna seguinte (mesma linha do endereço); eu não consegui fazer com que a primeira coluna informe se foi enviado ou não, podem me ajudar com isso tbm?
Option Explicit
Sub Enviar_email()
Dim enderecos As Range
Dim celula As Range
Dim anexo As String
Dim r As Integer
Dim fim
Dim enviar
Dim objOlAppApp As Outlook.Application
Dim objOlAppMsg As Outlook.MailItem
Dim objOlAppRecip As Outlook.Recipient
Set objOlAppApp = CreateObject(“Outlook.Application”)
Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem)
'Celulas com os endereços
Set enderecos = Range(“C2:C30”)
With objOlAppMsg
'Processar endereços para o envio
For Each celula In enderecos
If celula.Text <> “” And InStr(1, celula.Text, “@”) > 0 Then
Set objOlAppRecip = .Recipients.Add(celula.Text)
‘definir o tipo do destinatario
Select Case UCase(celula.Offset(0, 1).Text)
Case "CC"
objOlAppRecip.Type = olCC
Case "BCC"
objOlAppRecip.Type = olBCC
Case ""
objOlAppRecip.Type = olTo
End Select
End If
Next celula
’verificar se existe destinatário(s)
If .Recipients.Count = 0 Then GoTo fim
’Anexar ficheiro(s), com o nome e caminho escrito na coluna E
’
'Para mais do que 1 anexo utilizar ; como separador
’Ex: c:\anexo1.txt;c:\anexo2.txt;c:\anexo3.txt
’
anexo = Range(“E2”)
'testar se existe anexos
If Len(anexo) = 0 Then GoTo enviar
’tratar anexos
Dim anexos
anexos = Split(anexo, “;”)
Dim i
For i = LBound(anexos) To UBound(anexos)
'verificar se o caminho para o anexo é válido
If Dir(anexos(i)) = “” Then
r = MsgBox(“Anexo '” & anexos(i) & _
"'inexistente ou caminho invalido, " & _
"pretende enviar assim mesmo ? ", _
vbYesNo, _
“Erro na localização do anexo”)
If r <> vbYes Then GoTo fim
Else
.Attachments.Add anexos(i)
End If
Next i
enviar:
'definir a sua importancia
.Importance = olImportanceHigh
'O assunto
.Subject = “Relatório de Produção individual” & Format(Now, “dd-mmm.yyyy hh:mm:ss”)
'O conteudo do Mail mais a assinatura (caso exista)
.Body = "Segue em anexo a sua produção, não estão contabilizadas as PN´s " & vbCrLf & _
“Caso exista a necessidade de correção de ponto, favor realizar.” & _
vbCrLf & _
Assinatura
'enviar mensagem
.Send
End With
fim:
'Libertar as variaveis
Set objOlAppApp = Nothing
Set objOlAppMsg = Nothing
Set objOlAppRecip = Nothing
End Sub
‘
’ Função usada para tratar o pedido de inserção de assinatura
’
Function Assinatura()
Dim fAssinatura, stAssinatura, stLinha
fAssinatura = Environ(“APPDATA”) & “\Microsoft\Signatures” & Range(“F2”)
stAssinatura = ""
If Dir(fAssinatura) <> “” Then
Open fAssinatura For Input As #1
Do While Not EOF(1)
Line Input #1, stLinha
stAssinatura = stAssinatura & vbCrLf & stLinha
Loop
Close #1
End If
Assinatura = stAssinatura
End Function
