Outlook VBA - Desanexando todos arquivos

Outro dia me deparei com uma situação diferente: ter de desanexar aproximadamente 150 arquivos/e-mails.

Adaptando um código que peguei na internet, resolvi a parada movendo todos os e-mails para uma pasta temporária, criada apenas para esta finalidade e resolvi o problema na boa.

Abaixo o código.

Option Explicit
 
Public Sub salvar_anexos()
On Error GoTo erro
 
    Dim objApp          As Outlook.Application
    Dim pasta_outlook   As Outlook.MAPIFolder
    Dim objItem         As Object
    Dim arq_anexo       As Outlook.Attachment
    Dim pasta           As String
 
    'Pasta onde serão gravados os arquivos anexos dos emails:
    pasta = "C:\Teste"
   
    Set objApp = Outlook.Application
    Set pasta_outlook = objApp.ActiveExplorer.CurrentFolder
   
    If MsgBox("Deseja desanexar todos os arquivos da pasta " & pasta_outlook.Name, vbYesNo) = vbNo Then Exit Sub
   
    For Each objItem In pasta_outlook.Items
        DoEvents
        'Se o objeto é do tipo email, começa a desanexar os arquivos
        If objItem.Class = olMail Then
            For Each arq_anexo In objItem.Attachments
                DoEvents
                arq_anexo.SaveAsFile pasta & "\" & arq_anexo.FileName
            Next arq_anexo
        End If
    Next objItem
 
    MsgBox "Processo finalizado!", vbOKOnly
   
    Exit Sub
 
erro:
    MsgBox Err.Number & " - " & Err.Description, vbOKOnly
    Exit Sub
   
End Sub