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