Inquiridor
Forma de salvar XML em uma pasta especifica (OUTLOOK)

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
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
-