none
Forma de salvar XML em uma pasta especifica (OUTLOOK) RRS feed

  • Pergunta

  • Boa tarde !

    Gostaria de saber se teria alguma maneira de salvar um arquivo XML em uma pasta especifica do computador (SERVIDOR),ja pesquise vi maneiras pelo VBA , e tem que fazer macro pelo no outlook só que não estou conseguindo peças postagens, alguém poderia me ajuda

    toda vez que chega se um EMAIL com arquivos no formato xml  emAnexo ele salvar na pasta de xml

    Grato

    sexta-feira, 7 de outubro de 2016 19:28

Todas as Respostas

  • 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

    sexta-feira, 16 de fevereiro de 2018 01:52
  • Alex, fiz esta rotina e ele funcionou somente uma vez, ficou copiando os arquivos para onde eu queria mesmo, mas depois que reiniciei o computador não funcionou mais, porque será?

    terça-feira, 17 de setembro de 2019 22:16