NF-E - XML PARA O VISUAL BASIC

As funções abaixo ajudam na leitura de um arquivo XML da NF-e.

Você só precisa fazer a leitura das tags corretas e lançá-las na
base de dados - que pode ser em Access, SQL ou MySQL.

Para que funcione a contento, você precisa setar em References as
devidas bibliotecas associadas a MSXLM DOM.


As funções foram extraídas da internet.


'LENDO O XML
Private Sub LoadSettings()
Dim objNode As XMLNode
Dim objSubNode As XMLNode

'Does the Settings.xml file exist?
If PathExists("C:\NF-E\13090404672291000115550040000000280000000745-nfe.xml") Then
'Parse XML file and get top level node
Set objNode = XMLParse("C:\NF-E\13090404672291000115550040000000280000000745-nfe.xml", XML_FILE).Item("NFe")

Dim oRs As New ADODB.Recordset
Dim oRx As New ADODB.Recordset
Dim sSQL2 As String

'SE NÃO EXISTIR O MUNICÍPIO, INSERE OS DADOS DO MESMO
sSQL2 = "INSERT INTO XML(NFE, CUF, CNF) VALUES ( '" & _
Right(ID, 44) & "', '" & UF & "', '" & cNF & "')"


Cn.Execute sSQL2

MsgBox "LENDO OS DADOS COM SUCESSO!!", vbInformation, "XML"



End If
End Sub

Public Function Parse() As VBA.Collection
Dim strData As String
Dim i As Byte

'Get the XML data
If Flags And XML_FILE Then
'It is on disk so read it
strData = ReadFile(Data)
Else
'Otherwise just make a copy into our local
'variable (modifications are made)
strData = Data
End If

'Remove comments / id tags
StripTags strData, ""
StripTags strData, ""

'Remove the null characters
strData = Replace(strData, vbNullChar, vbNullString)

'Create a new collection
Set Parse = New Collection

'Are we supposed to overwrite data?
If Flags And XML_OVERWRITE Then
Set Nodes = Parse
End If

'Begin parsing!
ParseRec strData, Parse

End Function

Private Sub ParseRec(ByRef strData As String, ByVal colNodes As VBA.Collection)
'------------------------------------------------------------------
'Purpose: Recursive function which goes through all the data
' given to parse for XML until there is none left
'
'Params:
' strData: Data to parse
' colNodes: Current level collection of nodes
'------------------------------------------------------------------

Dim i As Long
Dim k As Long
Dim strValue As String
Dim strName As String
Dim objNode As XMLNode

'Find first <
i = InStrB(1, strData, "<")

'Keep looping while there are <
Do While i
'Alright there is a node; create a new one
Set objNode = New XMLNode

'Find end of first tag
k = InStrB(i, strData, ">")

'If there is no >, then we've got bad XML
If k = 0 Then
Exit Do
End If

'Extract data inbetween <>
strName = MidB$(strData, i + 2, k - i - 2)

'Check for a space in the name
i = InStrB(1, strName, " ")

'If there is a space, there may be attributes,
'otherwise no
If i Then
'Extract name of node
objNode.Name = LeftB$(strName, i - 1)

'Parse attributes if any
ParseAttr MidB$(strName, i + 2), objNode.Attributes

'If the name ends in a /, then there is no end tag
'otherwise there is
If AscW(RightB$(strName, 2)) = CHR_FSLASH Then
i = 0
Else
i = 1
End If
Else
'If the name ends in a /, then there is no end tag
'otherwise there is
If AscW(RightB$(strName, 2)) = CHR_FSLASH Then
'Trim off / from name
objNode.Name = LeftB$(strName, LenB(strName) - 2)
i = 0
Else
objNode.Name = strName
i = 1
End If
End If

'If i is non-zero, then we have to find the end tag
If i Then
'Find end tag position
i = InStrB(k, strData, "")

'Did we find it?
If i Then
'Extract value
strValue = MidB$(strData, k + 2, i - k - 2)

'Parse any nodes which might be inside
ParseRec strValue, objNode.Nodes

'Unescape escape sequences
objNode.Value = XMLUnescape(strValue)

If objNode.Name = "cUF" Then
UF = objNode.Value
End If
If objNode.Name = "cNF" Then
cNF = objNode.Value
End If
'Should equal position of last character for this node
k = i + LenB(objNode.Name) + 4
Else
'Malformed XML; quit
Exit Do
End If
End If

'Remove parsed data from string
strData = MidB$(strData, k + 2)

'Index node in collection
On Error Resume Next
colNodes.Add objNode, objNode.Name

'If an error occured, then we should add it to
'the collection without indexing it (it's already taken)
If Err.Number Then
colNodes.Add objNode

'Clear error
Err.Clear
End If

'Find next <
i = InStrB(1, strData, "<")
Loop

End Sub

Private Sub ParseAttr(ByRef strAttr As String, ByVal colAttr As VBA.Collection)
'------------------------------------------------------------------
'Purpose: To parse an attribute list for an XML tag and to place
' them inside the collection
'
'Params:
' strAttr: List of attributes/values seperated by
' spaces
' colAttr: Collection to add XMLAttr objects to
'------------------------------------------------------------------

Dim c As Integer
Dim i As Long
Dim objAttr As XMLAttr

'Find first equal's sign
i = InStrB(1, strAttr, "=")

'Loop as long as there are attributes
Do While i
'Create new attribute
Set objAttr = New XMLAttr

'Extract name (may have leading space(s))
objAttr.Name = LTrim$(LeftB$(strAttr, i - 1))

'Skip ahead to value
strAttr = MidB$(strAttr, i + 2)

'Get first character
c = AscW(strAttr)

'How is the attributed formated; surrounding quotes or no?
Select Case c
Case CHR_SQUOTE, CHR_DQUOTE
'Find ending quote
i = InStrB(3, strAttr, ChrW$(c))

'Did we find it?
If i Then
'Extract value and skip past this attribute
objAttr.Value = XMLUnescape(MidB$(strAttr, 3, i - 3))
strAttr = MidB$(strAttr, i + 2)
Else
'Bad XML!
Exit Do
End If
Case Else
'A space then will herald then end
i = InStrB(1, strAttr, " ")

'Did we find one?
If i Then
'Extract value and then skip past current attribute data
objAttr.Value = XMLUnescape(LeftB$(strAttr, i - 1))
strAttr = MidB$(strAttr, i + 2)
Else
'It is the last attribute; copy remaining data and
'exit loop
objAttr.Value = XMLUnescape(strAttr)
Exit Do
End If
End Select

If objAttr.Name = "Id" Then
ID = objAttr.Value
End If

If objAttr.Name = "UF" Then
UF = objAttr.Value
End If


'Add to collection
colAttr.Add objAttr, objAttr.Name

'Find next attribute
i = InStrB(1, strAttr, "=")
Loop

End Sub

Public Function XMLUnescape(ByRef strData As String) As String
'------------------------------------------------------------------
'Purpose: Converts escape sequences for XML into the actual
' characters
'
'Params:
' strData: String to search for escaped characters in
'
'Returns: String with escaped characters converted back to actual
' representation
'------------------------------------------------------------------

Dim i As Long

XMLUnescape = strData

If LenB(XMLUnescape) Then
i = InStrB(1, XMLUnescape, "&")

'If there is a & in the string, that is where we should start searching
If i Then
'Make sure there is a semi colon, telling us there may be escape sequences
If InStrB(i, XMLUnescape, ";") Then
'Escape various illegal characters
If InStrB(i, XMLUnescape, "<") Then XMLUnescape = Replace(XMLUnescape, "<", "<")
If InStrB(i, XMLUnescape, ">") Then XMLUnescape = Replace(XMLUnescape, ">", ">")
If InStrB(i, XMLUnescape, """) Then XMLUnescape = Replace(XMLUnescape, """, """")
If InStrB(i, XMLUnescape, "'") Then XMLUnescape = Replace(XMLUnescape, "'", "'")
If InStrB(i, XMLUnescape, "&") Then XMLUnescape = Replace(XMLUnescape, "&", "&")
End If
End If
End If

End Function

Public Function XMLParse(ByRef strData As String, ByVal lngFlags As Long) As VBA.Collection
'------------------------------------------------------------------
'Purpose: Wrapper method to quickly parse an XML document
'
'Params:
' strData: Data property of XMLDoc
' lngFlags: Flags property of XMLDoc
'
'Returns: Reference to top-level nodes collection
'------------------------------------------------------------------

Dim objXML As XMLDoc

'Create new XML object
Set objXML = New XMLDoc

'Copy data/flags params
objXML.Data = strData
objXML.Flags = lngFlags

'Parse / return collection
Set XMLParse = objXML.Parse()

'Destroy XMLDoc reference
Set objXML = Nothing

End Function