Jump to content
Fórum Script Brasil
  • 0

Manipular emails numa pasta do outlook pelo excel


Question

 
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: [email protected]---------------------|
'|---------------------------------------------------------------------------------------------------------|
 
End Sub


 
Link to post
Share on other sites

0 answers to this question

Recommended Posts

There have been no answers to this question yet

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Cloud Computing


  • Forum Statistics

    • Total Topics
      148722
    • Total Posts
      644552
×
×
  • Create New...