Olá.
Este código que aperfeiçoei com base em vários modelos que encontrei na internet. Ele renomeia e salva os XML das notas em três pastas uma para as CTe, uma para as NFe e uma para as NFCe.
Espero que seja útil para mais alguém.
Public Sub ProcessarAnexo(Email As Outlook.MailItem)
Dim DiretorioAnexos As String
DiretorioAnexos = "X:\NOTAS\"
Dim MailID As String
Dim Mail As Outlook.MailItem
Dim Anexo As Outlook.Attachment
Dim FSO As Object
MailID = Email.EntryID
Set Mail = Application.Session.GetItemFromID(MailID)
For Each Anexo In Mail.Attachments
If Right(Anexo.FileName, 4) = ".xml" Or Right(Anexo.FileName, 4) = ".XML" Then
Anexo.SaveAsFile DiretorioAnexos & Anexo.FileName
Set objParser = CreateObject("Microsoft.XMLDOM")
objParser.Load (DiretorioAnexos + Anexo.FileName)
oldFileName = DiretorioAnexos + Anexo.FileName
If (objParser.getElementsByTagName("mod").Length = 1) Then
Set ElemList = objParser.getElementsByTagName("mod")
ver = ElemList.Item(0).text
ElseIf (objParser.getElementsByTagName("procEventoNFe").Length = 1) Then
newFileName = DiretorioAnexos & "NFe\" & Anexo.FileName
ElseIf (objParser.getElementsByTagName("procEventoCTe").Length = 1) Then
newFileName = DiretorioAnexos & "CTe\" & Anexo.FileName
Else
newFileName = DiretorioAnexos & Anexo.FileName
GoTo Fim
End If
If ver = "55" Then
Set ElemList = objParser.getElementsByTagName("nNF")
nNF = Format(ElemList.Item(0).text, "000000")
Set ElemList = objParser.getElementsByTagName("chNFe")
chNFe = ElemList.Item(0).text
Set ElemList = objParser.getElementsByTagName("dhEmi")
dhEmi = ElemList.Item(0).text
dhEmi = Replace(dhEmi, ":", "-")
dhEmi = Left(dhEmi, 19)
Set ElemList = objParser.getElementsByTagName("xNome")
xNome = ElemList.Item(0).text
xNome = Special_Characters((xNome))
xNome = Left(xNome, 20)
newFileName = DiretorioAnexos & "NFe\" & dhEmi + "_" + nNF + "_" + xNome + "_" + chNFe + ".xml"
ElseIf ver = "65" Then
Set ElemList = objParser.getElementsByTagName("nNF")
nNF = Format(ElemList.Item(0).text, "000000")
Set ElemList = objParser.getElementsByTagName("chNFe")
chNFe = ElemList.Item(0).text
Set ElemList = objParser.getElementsByTagName("dhEmi")
dhEmi = ElemList.Item(0).text
dhEmi = Replace(dhEmi, ":", "-")
dhEmi = Left(dhEmi, 19)
Set ElemList = objParser.getElementsByTagName("xNome")
xNome = ElemList.Item(0).text
xNome = Special_Characters((xNome))
xNome = Left(xNome, 20)
newFileName = DiretorioAnexos & "NFCe\" & dhEmi + "_" + nNF + "_" + xNome + "_" + chNFe + ".xml"
ElseIf ver = "57" Then
Set ElemList = objParser.getElementsByTagName("nCT")
nCT = Format(ElemList.Item(0).text, "000000")
If (objParser.getElementsByTagName("chCT").Length = 1) Then
Set ElemList = objParser.getElementsByTagName("chCT")
chCT = ElemList.Item(0).text
Else
Set ElemList = objParser.getElementsByTagName("chCTe")
chCT = ElemList.Item(0).text
End If
Set ElemList = objParser.getElementsByTagName("dhEmi")
dhEmi = ElemList.Item(0).text
dhEmi = Replace(dhEmi, ":", "-")
dhEmi = Left(dhEmi, 19)
Set ElemList = objParser.getElementsByTagName("xNome")
xNome = ElemList.Item(0).text
xNome = Special_Characters((xNome))
xNome = Left(xNome, 20)
newFileName = DiretorioAnexos & "CTe\" & dhEmi + "_" + nCT + "_" + xNome + "_" + chCT + ".xml"
Else
newFileName = DiretorioAnexos & Anexo.FileName
End If
Fim:
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(newFileName) = False Then
FSO.MoveFile oldFileName, newFileName
Else
FSO.DeleteFile oldFileName, True
End If
End If
Next
Set Mail = Nothing
End Sub
Function Special_Characters(TESTVALUE As String)
Dim changename As String
Dim SP As String
Dim SP_C() As String
changename = TESTVALUE
SP = "! @ # $ % ^ & * * ( ) _ + = - \ | ] } [ { ' : / ? > . < , ; "
SP_C = Split(SP, " ")
For I = o To UBound(SP_C)
CHAR = SP_C(I)
changename = Replace(changename, CHAR, "")
Next
Special_Characters = changename
End Function
