Salvar item do Outlook no computador

[Wagner Morel]

Pessoal,

Boa tarde!

Sei que não temos uma área própria para desenvolvimento de VBA em Outlook e, por essa razão estou colocando essa dúvida aqui. Preciso de um código VBA para Outlook que salve os itens lidos e já fechados que estão na pasta Itens Enviados do Outlook, em qualquer pasta no computador local (que pode ser definida em uma variável Caminho, por exemplo).

Essa mesma solicitação estou colocando em outros dois fóruns.

[Wagner Morel]

Pessoal, bom dia!

Agradeço a todos que leram e que tentaram, de algum modo, ajudar. Pesquisei um pouco mais e após gastar mais alguns neurônios, achei a solução. Segue abaixo para quem tiver a mesma necessidade em algum momento:

Código: Selecionar todos

Sub SaveEmailNoComputador()
    '================================================================================
    'Código Desenvolvido por Wagner Morel em 01/06/2020 para salvar itens que estão _
    em Itens Enviados no Outlook em uma pasta na Unidade C.
    '================================================================================
    'Cria variáveis
    Dim myOlapp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim MinhaPasta As Outlook.MAPIFolder
    Dim MeuItem As Outlook.MailItem
    Dim Caminho As String
    Dim Assunto As String
    
    'Atribui valores aos objetos do outlook
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNamespace = myOlapp.GetNamespace("MAPI")
    
    'Define a pasta onde os arquivos serão salvos
    Caminho = "C:\Users\WAGNER MOREL\"
    
    'Atribui a variável objeto do outlook a pasta Itens Enviados
    Set MinhaPasta = myNamespace.GetDefaultFolder(olFolderSentMail)
    
    'Laço para varrer cada arquivo da pasta Itens Enviados
    For Each MeuItem In MinhaPasta.Items
        'Tratamento do caracteres que não podem estar contidos no assunto (para salvar)
        'Armazena o assunto
        Assunto = MeuItem.Subject
        'Retira barras normais
        Assunto = Replace(Assunto, "/", "-")
        'Retira barras invertidas
        Assunto = Replace(Assunto, "\", "-")
        'Retira pontos
        Assunto = Replace(Assunto, ".", "")
        'Salva os itens na pasta especificada com o nome do assunto
        MeuItem.SaveAs Caminho & Assunto & ".msg"
    Next
    
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
End Sub