Manipular emails numa pasta do outlook pelo excel

[vitorlsantos]

 

Private Sub manipularEmailsemPastas()

 

'|---------------------------------------------------------------------------------------------------|

'|--Autor: Vitor Luiz dos Santos -- Data: 28/03/2019 ------------------------------------------------|

'|---------------------------------------------------------------------------------------------------|

'|--ATENÇÂOO - ESSE CÓDIGO SÓ FUNCIONA SE TU ATIVAR A REFERENCIA Microsft Outlook 16.0 Object Library|

'|---------------------------------------------------------------------------------------------------|

 

Dim outApp, mySpace, myFolder, emailItem As Object, row As Integer

'O abaixo é só se você quiser salvar uma pasta e colocar o email e os anexos dentro

Dim pathFile As String, Attachment As Outlook.Attachment

 

'Cria um objeto de outlook. Importante que o outlook esteja aberto. Caso não esteja ou queira testar use o CreateObject

Set outApp = GetObject(Class:="Outlook.Application") 'Caso saiba que o outlook estará aberto

'Set outApp = CreateObject(Class:="Outlook.Application") 'Caso não saiba se o outlook estará aberto

 

'Pega as pastas do seu email

Set mySpace = outApp.GetNamespace("MAPI") 'Não há outro tipo se não o MAPI que pega a sessão que está no outlook

 

'Pega a pasta especificada. Neste caso eu pego a pasta de enviados, mas poderia ser qualquer dafult

Set myFolder = mySpace.getDefaultFolder(olFolderSentMail) 'A lista de defaults está em https://docs.microsoft.com/pt-br/office/vba/api/outlook.oldefaultfolders

 

'Vai na pasta que está sendo executada, na primeira planilha e cria os cabeçalhos nas células a1 até a k1

ThisWorkbook.Worksheets(1).Range("A1:K1").Value = Array("Título", "Quem enviou", "Para", "Data e Hora", _

"Anexos", "Tamanho", "Última modificação", "Categoria", "Nome do Remetente", "Tipo de acompanhamento", "Conteúdo")

 

'Defino a primeira linha

row = 2

 

For Each emailItem In myFolder.Items

 

'|---------------------------------------------------------------------------------------------------|

'|--Este Código serve para caso queira pegar as informações dos emails-------------------------------|

'|---------------------------------------------------------------------------------------------------|

'Pego o email |

With emailItem ' |

Cells(row, 1) = .Subject 'Assunto do e-mail |

Cells(row, 2) = .SenderEmailAddress 'E-mail do remetente |

Cells(row, 3) = .To 'E-mail do destinatário |

Cells(row, 4) = .ReceivedTime 'Data/Hora de recebimento |

Cells(row, 5) = .Attachments.Count 'Número de anexos |

Cells(row, 6) = .Size 'Tamanho da mensagem em bytes |

Cells(row, 7) = .LastModificationTime 'Última modificação |

Cells(row, 8) = .Categories 'Categoria |

Cells(row, 9) = .SenderName 'Nome do remetente |

Cells(row, 10) = .FlagRequest 'Acompanhamento |

'Cells(r, 11) = olItem.Body 'corpo do email - CUIDADO |

End With ' |

row = row + 1 ' |

'|---------------------------------------------------------------------------------------------------|

 

'|---------------------------------------------------------------------------------------------------|

'|--Este Código serve para caso queira salvar os emails como msg em alguma pasta---------------------|

'|---------------------------------------------------------------------------------------------------|

emailItem.SaveAs Environ("temp") & "\file.msg" 'Environ pega a pasta default temp do usuário |

'|---------------------------------------------------------------------------------------------------|

 

'|---------------------------------------------------------------------------------------------------|

'|--Este Código serve para criar uma pasta para cada email e salvar o email e os anexos--------------|

'|---------------------------------------------------------------------------------------------------|

pathFile = Environ("temp") & Replace(Replace("\Email_" & Left(emailItem.Subject, 40) & "_Hora" & _

emailItem.ReceivedTime, ":", "_"), "/", "") ' |

' |

On Error Resume Next ' |

'Se não tiver esse diretório, cria |

If (Dir(pathFile, vbDirectory) = "") Then MkDir Path:=pathFile ' |

'Comente essa parte caso não queira a mensagem |

If (Dir(pathFile & "\mensagem", vbDirectory) = "") Then MkDir Path:=pathFile & "\mensagem" ' |

'Comente essa parte caso não queira os anexos |

If (Dir(pathFile & "\anexos", vbDirectory) = "") Then MkDir Path:=pathFile & "\anexos" ' |

' |

On Error GoTo 0 ' |

' |

emailItem.SaveAs pathFile & "\mensagem\mensagem.msg" 'Mensagem |

' |

For Each Attachment In emailItem.Attachments ' |

Attachment.SaveAsFile pathFile & "\anexos\" & Attachment.DisplayName 'Anexos |

Next Attachment ' |

'|---------------------------------------------------------------------------------------------------|

 

Next emailItem

 

'|---------------------------------------------------------------------------------------------------------|

'|--Fontes: |

'|Get Object: |

'|https://docs.microsoft.com/pt-br/office/vba/language/reference/user-interface-help/getobject-function |

'|Create Object: |

'|https://docs.microsoft.com/pt-br/office/vba/language/reference/user-interface-help/createobject-function |

'|GetNameSpace - Propriedade de Outlook.Application: |

'|https://docs.microsoft.com/pt-br/office/vba/api/outlook.application.getnamespace |

'|Environ: |

'|https://docs.microsoft.com/pt-br/office/vba/language/reference/user-interface-help/environ-function |

'|GetDefaultFolder: |

'|https://docs.microsoft.com/pt-br/office/vba/api/outlook.namespace.getdefaultfolder |

'|Arrays: |

'|https://docs.microsoft.com/pt-br/office/vba/language/reference/user-interface-help/array-function |

'| |

'|---------------------------------------------------------------------------------------------------------|

'|--Email para ajuda: vitorluizd.santos@gmail.com----------------------------------------------------------|

'|---------------------------------------------------------------------------------------------------------|

 

End Sub