Envio de email pelo Excel - por data de expiração e destinatário variável

Question

Bem pessol, estou com um pequeno problema. Tenho uma planilha de controle de disponibilidade de arquivos em rede, onde cada solicitação tem uma data de expiração e quando atingir esse limite tenho que enviar um email para o solicitante informando que o arquivo expirou o tempo de disponibilidade na rede.

A planilha tem o seguinte modelo:

S I G L A - U S U A R I O	Data que expira	Data envio última notificação
AF	6/3/2012	6/2/2012
AEB	6/3/2012	6/2/2012
AEB	29/3/2012
AFD	6/3/2012	6/2/2012
AGM	13/3/2012
AGM	14/3/2012

Sendo que, o email dos usuários são defindos pela sigla de logon, preciso de duas variáveis, onde uma determinará o destinatário do email e outra validará se a data está expirada ou não para enviar ou não o email.

Pesquisando um pouco cheguei a esse código:

Code Snippet

Sub Envio_Email()

Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
Set Planilha = Sheets(1)

Conteúdo = "Cod" & vbTab & vbTab & "Data" & vbTab & vbTab & "Empresa" & vbTab & vbTab & "Produto" & vbLf

N = Planilha.Cells(Planilha.Rows.Count, 2).End(xlUp).Row

For i = 2 To N
    DataRef = CDate(Planilha.Cells(i, 2).Value)
    If DataRef < Date Then
    Conteúdo = Conteúdo & Trim(Planilha.Cells(i, 1)) & vbTab & vbTab
    Conteúdo = Conteúdo & Trim(Planilha.Cells(i, 2)) & vbTab & vbTab
    Conteúdo = Conteúdo & Trim(Planilha.Cells(i, 3)) & vbTab & vbTab
    Conteúdo = Conteúdo & Trim(Planilha.Cells(i, 4)) & vbLf
    End If
Next i

With myItem
    .To = "[e-mail]"
    .Subject = "Expirado a data de disponibilidade de seus arquivos"
    .Body = Conteúdo
    .Save
End With

End Sub

Porém, não consegui mudar para que o destinatário seja definido pela coluna onde estão as respectivas siglas dos solicitantes dos arquivos em rede.

Meu conhecimento de VBA é precário, preciso da ajuda de vcs para resolver este pequeno impasse.

Answer 1

Seu código precisa de somente algumas alterações, que são elas:

Seu bloco With deve ficar dentro do bloco For antes do Endif, e após o comando .TO deve ser colocado o caminho da celula onde contém o email do destinatário.

Qualquer dúvida estou a disposição

Answer 2

Ficaria dessa forma então?

Private Sub CommandButton1_Click()
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
Set Planilha = Sheets(1)

N = Plan1.Cells(Plan1.Rows.Count, 1).End(xlUp).Row

For i = 3 To N
    DataRef = CDate(Plan1.Cells(i, 4).Value)
    If DataRef < Date Then
    Conteúdo = "Prezado(a)" & vbCrLf & "Estamos realizando uma tarefa de limpeza de dados no nosso servidor MMSPOFOR que hospeda vários documentos de usuários e com isso localizamos uma pasta que está com a sua sigla (" & Trim(Plan1.Cells(i, 1)) & ") contendo alguns documentos." & vbCrLf & vbCrLf & "Link com arquivos para verificação: \\mmspofor\dados$\" & Trim(Plan1.Cells(i, 2)) & vbCrLf & vbCrLf & "Gostaríamos de saber que medidas podemos tomar:" & vbCrLf & "- Apagar a pasta;" & vbCrLf & "- Manter a pasta armazenada por mais N dias, tendo como limite 30 dias." & vbCrLf & "- Fazer um backup em CD/DVD e apagar do servidor." & vbCrLf & "Obs.: Em caso de backup de CD/DVD, a mídia deve ser fornecida pelo solicitante." & vbCrLf & "Obrigado pela atenção." & vbCrLf
        With myItem
            .To = "& Trim(Plan1.Cells(i, 1)) &@machadomeyer.com.br"
            .Subject = "Servidor temporario de arquivos (MMSPOFOR)"
            .Body = Conteúdo
            .Save
        End With
    End If
Next i

End Sub

Answer 3

Isso mesmo Fernando.

Só dê mais uma conferida nas concatenações para que o código funcione da maneira desejada

ex.: .To = Trim(Plan1.Cells(i, 1))  & "@machadomeyer.com.br"

Abrç

Answer 4

Jhonatan, fiz a alteração que vc informou, mas não enviou nenhum e-amail.

Fiz a depuração do código e não retornou nenhum erro, aparentemente as variáveis recebem os dados esperados, mas não foi recebido nenhum email nos testes que efetuei.

Será que tenho que habilitar alguma outra bibliotecao diferente da Microsoft Office 12.0 Object Library?

Grato pela ajuda.

Answer 5

No lugar de .save coloca .send

Answer 6

Ah! agora sim... essa meio que foi por dedução, ontem alterei esse comando e funcionou... porém está com outro erro.

Erro em tempo de execução '-2147221238 (8004010a)
O item foi movido ou excluido.

E na depuração indica a linha:

.To = Trim(Plan1.Cells(i, 1)) & "@machadomeyer.com.br"

a planilha que estou usando como base para os testes está no link abaixo:

http://bit.ly/xW8oFO

Vou pesquisar o erro na internet, caso eu encontre algo edito este post.

Grato!

Answer 7

Fernando

Após o envio de cada email deve ser limpado da memória as variáveis utilizadas para criação do email.

abaixo segue seu código com a alteração.

Sub h()
Set Planilha = Sheets(1)

N = Plan1.Cells(Plan1.Rows.Count, 1).End(xlUp).Row

For i = 3 To N
    DataRef = CDate(Plan1.Cells(i, 4).Value)
    If DataRef < Date Then
    Conteúdo = "Prezado(a)" & vbCrLf & "Estamos realizando uma tarefa de limpeza de dados no nosso servidor MMSPOFOR que hospeda vários documentos de usuários e com isso localizamos uma pasta que está com a sua sigla (" & Trim(Plan1.Cells(i, 1)) & ") contendo alguns documentos." & vbCrLf & vbCrLf & "Link com arquivos para verificação: \\mmspofor\dados$\" & Trim(Plan1.Cells(i, 2)) & vbCrLf & vbCrLf & "Gostaríamos de saber que medidas podemos tomar:" & vbCrLf & "- Apagar a pasta;" & vbCrLf & "- Manter a pasta armazenada por mais N dias, tendo como limite 30 dias." & vbCrLf & "- Fazer um backup em CD/DVD e apagar do servidor." & vbCrLf & "Obs.: Em caso de backup de CD/DVD, a mídia deve ser fornecida pelo solicitante." & vbCrLf & "Obrigado pela atenção." & vbCrLf
        
        Set myOlApp = CreateObject("Outlook.Application")
        Set myItem = myOlApp.CreateItem(olMailItem)
        Set myAttachments = myItem.Attachments
        
        With myItem
            .To = Trim(Plan1.Cells(i, 1)) & "@machadomeyer.com.br"
            .Subject = "Servidor temporario de arquivos (MMSPOFOR)"
            .Body = Conteúdo
            .Send
        End With
        
        myOlApp.Quit
        
        Set myOlApp = Nothing
        Set myItem = Nothing
        Set myAttachments = Nothing
    
    End If
Next i

End Sub

Obs.: Durante o teste enviei alguns email´s para os cadastros da plan peço desculpas

abraç

Answer 8

Jhonatan vc salvou a patria, com isso vou reduxis 2 dias de trabalho para apenas alguns minutos!Só mudei uma coisa, eu troquei a posiçao do comando "myOlApp.Quit" para que o Outlook não fosse fechado durante a execução do laço e sim ao final do comando. Ficou perfeito!!

Muito Obrigado pela ajuda!!

Answer 9

Fernando, voce teria o código final para eu testar? Aqui gerou um erro:

" Erro de tempo de execução '287': Erro de definição de aplicativo ou de definição de objeto"

Não consegui baixar a planilha no link indicado, voce poderia me ajudar? 

Obrigado