Boa tarde, Estou com uma dificuldade, possuo a macro abaixo que desanexa os arquivos no Outlook dos e-mail que possuem anexo, e numera os anexo sem sobrepor, gostaria de colocar a data do e-mail ou a data do arquivo (não do dia que estou salvando) no nome do arquivo, ao invés de numerar, alguém consegue ajudar?
Macro utilizada
Public Sub Desanexar_SEMSOBREPOR()
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
Dim NomeArquivo As String
Dim Extensao As String
Dim NovoNomeArquivo As String
Dim Contador As Integer
'Pasta onde serão gravados os arquivos anexos dos emails:
Pasta = "C:\Arquivos"
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
' Pega o nome do arquivo e a extensão
NomeArquivo = Left(Arq_anexo.FileName, InStrRev(Arq_anexo.FileName, ".") - 1)
Extensao = Mid(Arq_anexo.FileName, InStrRev(Arq_anexo.FileName, "."))
' Garante que o novo nome do arquivo seja único
NovoNomeArquivo = Pasta & "\" & Arq_anexo.FileName
Contador = 1
While Dir(NovoNomeArquivo) <> ""
NovoNomeArquivo = Pasta & "\" & NomeArquivo & "_" & Contador & Extensao
Contador = Contador + 1
Wend
' Salva o anexo com o novo nome
Arq_anexo.SaveAsFile NovoNomeArquivo
Next Arq_anexo
End If
Next ObjItem
MsgBox "Processo finalizado!", vbOKOnly
End Sub
