[Resolvido]Salvar Anexos do Microsoft Office Outlook 2003 para uma pasta de Arquivo

Boa noite amigos, me deparei com um problema nesta função:
Está função salva todos os anexos com a extenção marcada em uma pasta no computador, até ai funciona muito bem, desde que os arquivos em anexos não tenham o mesmo nome.
Estou tentando salvar os anexos mas todos ele vem com o mesmo nome, ex:

Arquivo Recebido
Infoemail_Bradesco.pdf 12/11//2012
Infoemail_Bradesco.pdf 11/11//2012
Infoemail_Bradesco.pdf 10/11//2012
Infoemail_Bradesco.pdf 09/11//2012

consequentemente tenho quatro ou mais arquivos, ele vai ler os quatro e só salvar um, pois todos tem o mesmo nome

São extratos bancarios que preciso salvá-los em uma pasta, mas como posso fazer para renomear os arquivos pela data de recebimento ou outra maneira de modo que ao
baixar do outllok não se sobreponha o primeiro, seria mais ou menos assim ou outra maneira:

Arquivo Recebido
Infoemail_Bradesco12112012.pdf 12/11//2012
Infoemail_Bradesco11112012.pdf 11/11//2012
Infoemail_Bradesco10112012.pdf 10/11//2012
Infoemail_Bradesco09112012.pdf 09/11//2012

Desde já, agradeço a quem puder me ajudar



Public Function GetAttachment()
On Error GoTo GetAttachment_err
' Declaração de variáveis
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim intNumerador As Integer
intNumerador = intNumerador + 1

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
'Verifica no seu inbox se existe algum anexo de acordo com a extensão especificada
If Inbox.Items.Count = 0 Then
MsgBox "Não existem arquivos na caixa de entrada.", vbInformation, _
"Concluido"
Exit Function
End If
' Check each message for attachments

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Then
FileName = "D:\ExtratosBradesco\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " arquivo(s)." _
& vbCrLf & "Arquivos salvos em D:\ExtratosBradesco." _
& vbCrLf, vbInformation, "Concluído!"

Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Function
' Handle errors
GetAttachment_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachment" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachment_exit
End Function

Coloque uma condição para o caso do arquivo já existir, acrescentar algo nele. Por exemplo:

Código:

Dim N As Integer
...
If Len(Dir(NomeDoAnexo, vbArchieve)) > 0 Then
    NomeDoAnexo = NomeDoAnexo & N
    N = N + 1
End If
...

Algo assim.

Criquio, obrigado pela sua atenção, mas em que lugar na função colocaria este código, pois acho que

Dim N As Integer
...
If Len(Dir(NomeDoAnexo, vbArchieve)) > 0 Then
NomeDoAnexo = NomeDoAnexo & N
aqui teria que ser acho FileName = FileName & N
N = N + 1
End If
Poderia me ajudar?

Com a adptação no código abaixo os arquivos estão sendo salvos assim:

Infoemail_Bradesco.pdf1
Infoemail_Bradesco.pdf2
Infoemail_Bradesco.pdf3
Infoemail_Bradesco.pdf4

Como modificar este código para que atualiza desta forma
Infoemail_Bradesco1.pdf
Infoemail_Bradesco2.pdf
Infoemail_Bradesco3.pdf
Infoemail_Bradesco4.pdf

ou como a data do recebimento do arquivo

Infoemail_Bradesco12112012.pdf
Infoemail_Bradesco11112012.pdf
Infoemail_Bradesco10112012.pdf
Infoemail_Bradesco09112012.pdf



Public Function GetAttachment()
On Error GoTo GetAttachment_err
' Declaração de variáveis
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim N As Integer


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0


'Verifica no seu inbox se existe algum anexo de acordo com a extensão especificada
If Inbox.Items.Count = 0 Then
MsgBox "Não existem arquivos na caixa de entrada.", vbInformation, _
"Concluido"
Exit Function
End If
' Check each message for attachments

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Then
If Len(Dir(FileName, vbArchieve)) > 0 Then
FileName = "D:\ExtratosBradesco\" & Atmt.FileName
i = i + 1
N = N + 1
FileName = FileName & N
Atmt.SaveAsFile FileName

End If
End If
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " arquivo(s)." _
& vbCrLf & "Arquivos salvos em D:\ExtratosBradesco." _
& vbCrLf, vbInformation, "Concluído!"

Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Function
' Handle errors
GetAttachment_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachment" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachment_exit
End Function

Criquio, perfeito, mais uma vez obrigado mesmo a você e a todos que colaboraram
Abaixo o código completo

Public Function GetAttachment()
On Error GoTo GetAttachment_err
' Declaração de variáveis
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim N As Integer


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0


'Verifica no seu inbox se existe algum anexo de acordo com a extensão especificada
If Inbox.Items.Count = 0 Then
MsgBox "Não existem arquivos na caixa de entrada.", vbInformation, _
"Concluido"
Exit Function
End If
' Check each message for attachments

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Then
If Len(Dir(FileName, vbArchieve)) > 0 Then
FileName = "D:\ExtratosBradesco\" & Atmt.FileName
i = i + 1
N = N + 1
'FileName = FileName & N
FileName = Left(FileName, Len(FileName) - 4) & N & ".pdf"
Atmt.SaveAsFile FileName

End If
End If
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " arquivo(s)." _
& vbCrLf & "Arquivos salvos em D:\ExtratosBradesco." _
& vbCrLf, vbInformation, "Concluído!"

Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Function
' Handle errors
GetAttachment_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachment" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachment_exit
End Function

Boa tarde..

Eu uso esse script para baixar os xml'se gravar na pasta, ele está funcionando, mas precisaria da ajuda de vcs para implementar uma busca por nome diferente.
Por exemplo, se o arquivo chamado: 35121012420995000129550010000008561000027685.xml existir na pasta, o script não grava novamente. Até aqui está ok...
Mas temos um sistema de gestão que renomeia os xml's que já foram importados para o mesmo e o arquivo fica com esse nome: 20112012-35121012420995000129550010000008561000027685.xml (coloca a data na frente)

Eu não domino vba. vejam o meu código abaixo, em que somente não está funcionando a verificação se o arquivo já existe utilizando a busca com o coringa " * " & nome_arquivo

Código:

Public Sub Baixar_xml(Email As MailItem)
    Dim DiretorioAnexos, MailID, chave As String
    DiretorioAnexos = "C:\nfe"  'cuidado - nao colocar barra \ no final do diretório
    'DiretorioAnexos = "O:"
    Dim Mail As Outlook.MailItem
    Set xmlDoc = CreateObject("Microsoft.xmlDOM")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set FolderObject = fso.GetFolder(DiretorioAnexos & "\")
    xmlDoc.Async = False
   
    MailID = Email.EntryID
    Set Mail = Application.Session.GetItemFromID(MailID)
   
    For Each Anexo In Mail.Attachments
        If (Right(Anexo.FileName, 3) = "xml") Or (Right(Anexo.FileName, 3) = "XML") Then
                'MsgBox (Anexo.FileName & " NomeArq")
                Anexo.SaveAsFile "C:\temp\" & "\" & Anexo.FileName
                xmlDoc.Load ("C:\temp\" & Anexo.FileName)
                chave = ""
                chave = xmlDoc.SelectSingleNode("//nfeProc/protNFe/infProt/chNFe").Text & ".xml"
                MsgBox chave & " chave"
                If (Not fso.FileExists(DiretorioAnexos & "\" & chave)) Then
                   
'--> mas aqui nesse for, a busca utilizando o coringa ' * ' não está funcionando

                    For Each f In FolderObject.Files
                        If f.Name = ("*" & chave) Then MsgBox "O arquivo está presente."
                    Next f
'-->
                    Anexo.SaveAsFile DiretorioAnexos & "\" & Anexo.FileName
                    fso.MoveFile DiretorioAnexos & "\" & Anexo.FileName, DiretorioAnexos & "\" & chave
                Else
                    MsgBox "Arquivo: " & Anexo.FileName & vbCrLf & "Chave  : " & chave & vbCrLf & " já existe! Este xml não será gravado.", vbInformation, "Aviso"
                End If
        End If
    Next
    Set Mail = Nothing
    Set fso = Nothing
   
End Sub


Desde já agradeço.

Olá, seja bem vindo ao fórum.
Essa data é sempre a data atual? Se for, tente implementar assim:

Código:


        ...
        If (Right(Anexo.FileName, 3) = "xml") Or (Right(Anexo.FileName, 3) = "XML") Then
            If Len(Dir(Anexo.FileName & " " & Format(Now, "yyyyddmm") & NomeArq)) <> 0 Then
                'MsgBox (Anexo.FileName & " " & Format(Now, "yyyyddmm") & NomeArq)
        ...

Obrigado pela recepção!

Infelizmente, a data não é sempre a data do dia.. pode ser variada.

Ah..dessa forma acima, nao funciona pois o nome do arquivo vem das mais variadas formas, por isso eu trato isso no código, salvando o arquivo na pasta C:\temp e depois movendo para C:\nfe com o nome correto.

Vcs sabem como fazer uma busca na pasta sem considerar o inicio do nome do arquivo?
ou com * (asterisco) ?
aqui no fórum tem um tópico que fala sobre isso, mas nao consegui fazer funcionar no outlook
http://maximoaccess.forumeiros.com/t4242-resolvidoprocurar-arquivo-usando-caracter-curinga

Tive este mesmo problema, com arquivos e extenções iguais, com a ajuda dos colaboradores, salvo o arquivo de acordo com a data do recebimento do mesmo.
Tente adaptar a sua nessecidade.


Public Function AnexoData()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
'Dim N As Integer
Dim N As Date
'Dim Ordem As Integer


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
'Ordem = 0

'Verifica no seu inbox se existe algum anexo de acordo com a extensão especificada
If Inbox.Items.Count = 0 Then
MsgBox "Não existem arquivos na caixa de entrada.", vbInformation, _
"Concluido"
Exit Function
End If
' Check each message for attachments

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Then
If Len(Dir(FileName, vbArchieve)) > 0 Then
FileName = "D:\ExtratosBradesco\" & Atmt.FileName
i = i + 1
'Ordem = Ordem + 1
'N = N + 1
N = Item.SentOn
'MsgBox Item.SentOn

'FileName = FileName & N
'FileName = Left(FileName, Len(FileName) - 4) & N & ".pdf"
FileName = Left(FileName, Len(FileName) - 4) & "_" & Format(N, "ddmmyyyy") & ".pdf"
Atmt.SaveAsFile FileName

End If
End If
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " arquivo(s)." _
& vbCrLf & "Arquivos salvos em D:\ExtratosBradesco." _
& vbCrLf, vbInformation, "Concluído!"

Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Function
End Function

jou.franco, testei este código e os arquivos são salvos no script de acordo com data e hora do recebimento, teste ele, talvez seja útil para voce

Public Sub SalvarAnexo(Item As MailItem)

Dim Atmt As Attachment
Dim FileName As String
Dim N As Date



For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "xml" Then
FileName = "D:\ArquivosXML\" & Atmt.FileName
'Atmt.SaveAsFile FileName
N = Item.SentOn
FileName = Left(FileName, Len(FileName) - 4) & "_" & Format(N, "ddmmyyyy_hhmm") & ".xml"
Atmt.SaveAsFile FileName
End If
Next Atmt

End Sub

muito obrigado pela ajuda Junior Meireles.

Mas tenho uma restrição que para o sistema poder importar o xml ele tem que estar com o nome
35121012420995000129550010000008561000027685.xml, por exemplo.

e depois que ele é importado, ele fica com o nome
ddmmaaaa-35121012420995000129550010000008561000027685.xml (data do dia da importaçao)

Por isso estou procurando uma maneira de fazer a busca pelo final do nome do arquivo ou usando o coringa *

ddmmaaaa-35121012420995000129550010000008561000027685.xml (data do dia da importaçao)

Bem, se é a data do dia da importação, a ideia que dei logo acima irá funcionar.

Criquio,

Infelizmente, a data não é sempre a data do dia.. ela pode ser variada...
por exemplo:
Um xml que foi importado semana passada... depois de baixado e importado para o meu ERP, fica com o nome:
15112012-35121012420995000129550010000008561000027685.xml

então se eu receber ou mandar baixar os xml novamente no email, ele vai ficar duplicado na pasta com o nome:
35121012420995000129550010000008561000027685.xml

Bem, se é a data do dia da importação, a ideia que dei logo acima irá funcionar.

ddmmaaaa-35121012420995000129550010000008561000027685.xml (data do dia da importaçao)

Veja no repositório de códigos VBA um exemplo de código utilizando o File que pode ser utilizado para isso. Você pode fazer um For...Next para verificar uma quantidade de caracteres à direita do nome dos arquivos e comparar com o que está importando. Se coincidir não importa. Caso contrário importa.

Percebo pouco de programação e neste sentido pedia a seguinte ajuda, é me enviado diariamente um ficheiro chamado Stock.xlsx e pretendia que o mesmo seja colocado numa pasta (Exemplo C:) podem enviar o código por favor.