1. Este site usa cookies. Ao continuar a usar este site está a concordar com o nosso uso de cookies. Saber Mais.

XML Engine (VB6) [Repositorio Codigo]

Discussão em 'Programação' iniciada por fLaSh_CF, 19 de Outubro de 2008. (Respostas: 0; Visualizações: 2014)

  1. fLaSh_CF

    fLaSh_CF Banido

    Boas;

    Coloco aqui umas classes para fácil acesso ao XML a partir do VB6, sem necessitar de dependencias/componentes extra!.
    Ideal para guardar informações como configurações da aplicação, registos, etc..

    A engine contem três classes:
    clsXMLAttr : esta class apena guarda temporariamente o "Item" da collection
    clsXMLDoc: esta class é o principal motor da engine, faz o parsing do ficheiro XML
    clsXMLNode: esta class é auxiliar da engine, armazena todos os nodes
    E um module:
    modGlobal: este module contem funções de leitura de ficheiros por API (é rapido), tambem funções importantes como XML Escape/Unescape (isto é importante!) para fazer o enconding/deconding de setrings com caracteres reservados por a linguagem XML.

    Nota: os comentarios estão em EG, fiz esta engine para um projecto open source, talvez mais tarde eu traduza para PT :)

    Depois de as classes e o module colucadas, pequeno exemplo do como utilizar:
    Código:
    [B]frmMain:[/B]
    Option Explicit
     
    Private m_objSettings   As New Settings
    Private Sub LoadSettings()
        Dim objNode     As XMLNode
        Dim objSubNode  As XMLNode
        'Does the Settings.xml file exist?
        If PathExists(App.Path & "\Settings.xml") Then
            'Parse XML file and get top level node
            Set objNode = XMLParse(App.Path & "\Settings.xml", XML_FILE).Item("Settings")
     
            For Each objNode In objNode.Nodes
                Select Case CInt(objNode.GetAttr("Type"))
                    Case vbString
                         CallByName m_objSettings, objNode.Name, VbLet, CStr(objSubNode.Value)
                    Case vbLong
                        CallByName m_objSettings, objNode.Name, VbLet, CLng(objSubNode.Value)
                    Case vbBoolean
                        CallByName m_objSettings, objNode.Name, VbLet, CBool(objSubNode.Value)
                    Case vbInteger
                        CallByName m_objSettings, objNode.Name, VbLet, CInt(objSubNode.Value)
                    Case vbByte
                        CallByName m_objSettings, objNode.Name, VbLet, CByte(objSubNode.Value)
                    Case vbDouble
                        CallByName m_objSettings, objNode.Name, VbLet, CDbl(objSubNode.Value)
                End Select
            Next
        End If
    End Sub
    Private Sub SaveSettings()
        Dim intFF       As Integer
        Dim strFile     As String
     
        strFile = App.Path & "\Settings.xml"
        intFF = FreeFile
     
        Open strFile For Append As intFF
            Print #intFF, vbXML
            Print #intFF, "<Settings Version=""" & "1.0" & """>"
            Print #intFF, vbTab & "<Longs>"
            Print #intFF, vbTab & vbTab & "<Long1>" & m_objSettings.Long1 & "</Long1>"
            Print #intFF, vbTab & vbTab & "<Long1>" & m_objSettings.Long1 & "</Long1>"
            Print #intFF, vbTab & "</Longs>"
            Print #intFF, vbTab & "<Integers>"
            Print #intFF, vbTab & vbTab & "<Integer1>" & m_objSettings.Integer1 & "</Integer1>"
            Print #intFF, vbTab & vbTab & "<Integer1>" & m_objSettings.Integer2 & "</Integer1>"
            Print #intFF, vbTab & "</Integers>"
            Print #intFF, vbTab & "<Booleans>"
            Print #intFF, vbTab & vbTab & "<Boolean1>" & m_objSettings.Boolean1 & "</Boolean1>"
            Print #intFF, vbTab & vbTab & "<Boolean1>" & m_objSettings.Boolean2 & "</Boolean2>"
            Print #intFF, vbTab & "</Booleans>"
            Print #intFF, vbTab & "<Strings>"
            Print #intFF, vbTab & vbTab & "<String1>" & m_objSettings.String1 & "</String1>"
            Print #intFF, vbTab & vbTab & "<String2>" & m_objSettings.String2 & "</String2>"
            Print #intFF, vbTab & "</Strings>"
            Print #intFF, vbTab & "<Bytes>"
            Print #intFF, vbTab & vbTab & "<Byte1>" & m_objSettings.Byte1 & "</Byte1>"
            Print #intFF, vbTab & vbTab & "<Byte2>" & m_objSettings.Byte2 & "</Bytes>"
            Print #intFF, vbTab & "</Bytes>"
            Print #intFF, "</Settings>";
        Close intFF
     
    End Sub
    Private Sub cmdLoadSet_Click()
        Set m_objSettings = New Settings
        LoadSettings
    End Sub
     
    Private Sub cmdSaveSet_Click()
        SaveSettings
    End Sub
    
    clsXMLAttr
    Código:
    '*******************************************
    '     Copyright: fLaSh - Carlos.DF
    'Email: [EMAIL="[email protected]"][email protected][/EMAIL]
    '              2008-10-19
    '*******************************************
    Option Explicit
    Public Name         As String
    Public Value        As String
    
    clsXMLDoc
    Código:
    '*******************************************
    '     Copyright: fLaSh - Carlos.DF
    'Email: [EMAIL="[email protected]"][email protected][/EMAIL]
    '              2008-10-19
    '*******************************************
    Option Explicit
    Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
                (Destination As Any, ByVal Length As Long)
    Public Data                 As String
    Public Flags                As Long
    Public Nodes                As VBA.Collection
    Private Const CHR_FSLASH    As Integer = 47 '/
    Private Const CHR_SQUOTE    As Integer = 39 ''
    Private Const CHR_DQUOTE    As Integer = 34 '"
     
    Private Sub Class_Initialize()
        Set Nodes = New Collection
    End Sub
    Private Sub Class_Terminate()
        Set Nodes = Nothing
    End Sub
    Public Function Parse() As VBA.Collection
        '------------------------------------------------------------------
        'Purpose:   To parse XML data, and put the parsed data into XMLNode
        '           and XMLAttr objects which are stored in collections
        '
        '           The collections are indexed by name; if more than one
        '           node has the same name, only the first is indexed
        '           (this makes the assumption that the parser user knows
        '           the format of the data it is requesting to be parsed)
        '
        '           If XML_FILE is on, it must read the data from disk
        '           before popping it in a variable (otherwise it just
        '           copies the data from the Data variable)
        '
        '           If XML_OVERWRITE is on, it will overwrite any nodes
        '           in the Nodes collection and will return a reference
        '           to Nodes; otherwise it will just create a new
        '           collection and it will be returned by the function
        '
        '           While in properly formatted XML there should be only
        '           one top level node, multiple top level nodes are
        '           supported and are stored in the Nodes collection
        '
        'Returns:   Collection containing top level nodes parsed
        '------------------------------------------------------------------
     
        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, "</" & objNode.Name & ">")
     
                '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)
     
                    '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
     
            'Add to collection
            colAttr.Add objAttr, objAttr.Name
     
            'Find next attribute
            i = InStrB(1, strAttr, "=")
        Loop
    End Sub
    Public Function Generate() As String
        '------------------------------------------------------------------
        'Purpose:   To generate the XML data from what is in the nodes
        '           collection automatically; it creates a temporary file
        '           and writes the data to this file
        '
        'Returns:   If XML_FILE is on, it returns a file path otherwise
        '           it returns raw XML data
        '------------------------------------------------------------------
     
        Dim intFF       As Integer
        Dim strFile     As String
        strFile = TempFile()
        intFF = FreeFile()
     
        'Open file for appending, and generate XML data starting at top level node
        Open strFile For Append Lock Write As intFF
        GenerateRec intFF, Nodes
        Close intFF
     
        'XML generated, how to return to user
        'Are with working with files or raw data?
        If Flags And XML_FILE Then
            'Are we allowed to overwrite things?
            If Flags And XML_OVERWRITE Then
                'If so, delete the old file, and rename the
                'temporary one to the path of the old file
                DeleteFile Data
                Name strFile As Data
     
                'Return path
                Generate = Data
            Else
                'Return path to temporary file
                Generate = strFile
            End If
        Else
            'Are we allowed to overwrite raw data?
            If Flags And XML_OVERWRITE Then
                'If so, place a copy in Data and return the same
                Data = ReadFile(strFile)
                Generate = Data
            Else
                'Otherwise, just return the raw data
                Generate = ReadFile(strFile)
            End If
     
            'Either way, we don't need this file anymore
            DeleteFile strFile
        End If
    End Function
    Private Sub GenerateRec(ByVal intFile As Integer, ByVal colNodes As VBA.Collection)
        '------------------------------------------------------------------
        'Purpose:   Recursive function which goes down the node heirarchy
        '           to generate properly formatted XML
        '
        'Params:
        '           intFile:    File handle where to write XML data
        '           colNodes:   Reference to node collection at current
        '                       level
        '------------------------------------------------------------------
     
        Dim objNode     As XMLNode
        Dim objAttr     As XMLAttr
        Dim colRef      As VBA.Collection
        For Each objNode In colNodes
            'Print header
            Print #intFile, "<" & objNode.Name;
     
            Set colRef = objNode.Attributes
     
            'Print out attributes if any
            If colRef.Count Then
                For Each objAttr In colRef
                    Print #intFile, " " & objAttr.Name & "=""" & XMLEscape(objAttr.Value) & """";
                Next
            End If
     
            'End header
            Print #intFile, ">";
     
            Set colRef = objNode.Nodes
     
            'If there are subnodes, there isn't any value to this node; in that case
            'call GenerateRec again for nodes inside of this node
            If colRef.Count Then
                GenerateRec intFile, colRef
            Else
                Print #intFile, XMLEscape(objNode.Value);
            End If
     
            Set colRef = Nothing
     
            'Print end of tag
            Print #intFile, "</" & objNode.Name & ">"
        Next
    End Sub
    Private Sub StripTags(ByRef strData As String, ByRef strStart As String, ByRef strEnd As String)
        '------------------------------------------------------------------
        'Purpose:   Removes all characters inbetween and including the
        '           starting and ending sequences provided and replaces
        '           them with null characters
        '
        'Params:
        '           strData:    String to strip (modifies original)
        '           strStart:   Starting sequence
        '           strEnd:     Ending sequence
        '------------------------------------------------------------------
     
        Dim i       As Long
        Dim k       As Long
        Dim h       As Long
        'Get the length of the ending term
        h = LenB(strEnd)
     
        'Remove comments
        i = InStrB(1, strData, strStart)
     
        Do While i
            'Find ending
            k = InStrB(i, strData, strEnd)
     
            'If it exists, replace comment with null chars
            'else replace the rest of the string with them
            If k Then
                ZeroMemory ByVal StrPtr(strData) + i - 1, k - i + h
            Else
                ZeroMemory ByVal StrPtr(strData) + i - 1, LenB(strData) - i + 1
                Exit Do
            End If
            'Find next comment
            i = InStrB(1, strData, strStart)
        Loop
    End Sub
    
    clsXMLNode
    Código:
    '*******************************************
    '     Copyright: fLaSh - Carlos.DF
    'Email: [EMAIL="[email protected]"][email protected][/EMAIL]
    '              2008-10-19
    '*******************************************
    Option Explicit
    Public Name         As String
    Public Value        As String
    Public Nodes        As VBA.Collection
    Public Attributes   As VBA.Collection
    Private Sub Class_Initialize()
        Set Nodes = New Collection
        Set Attributes = New Collection
    End Sub
    Private Sub Class_Terminate()
        Set Nodes = Nothing
        Set Attributes = Nothing
    End Sub
    Public Function GetAttr(ByRef strName As String) As String
        '------------------------------------------------------------------
        'Purpose:   Get the value of an attribute directly from the name
        '           rather than use the collection (from the point of
        '           view of the caller)
        '
        'Params:
        '           strName:    Name of the attribute to value of
        '
        'Returns:   Value of attribute; if the attribute doesn't exist
        '           vbNullString is returned
        '------------------------------------------------------------------
     
        On Error Resume Next
     
        GetAttr = Attributes(strName).Value
    End Function
    Public Function GetNode(ByRef strName As String) As XMLNode
        '------------------------------------------------------------------
        'Purpose:   Get a node directly rather than from the collection
        '           to avoid un-useful error messages
        '
        'Params:
        '           strName:    Name of node to retrieve
        '
        'Returns:   Object reference to node if it exists, otherwise it
        '           returns Nothing
        '------------------------------------------------------------------
     
        On Error Resume Next
     
        GetNode = Nodes(strName)
    End Function
    
    modGlobal:
    Código:
    '*******************************************
    '     Copyright: fLaSh - Carlos.DF
    'Email: [EMAIL="[email protected]"][email protected][/EMAIL]
    '              2008-10-19
    '*******************************************
    Option Explicit
    'File searching APIs
    Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
    Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    'Get clock tick
    Public Declare Function GetTickCount Lib "kernel32" () As Long
    'File property API
    Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
    'Structures for file searching APIs
    Public Type FILETIME
        dwLowDateTime   As Long
        dwHighDateTime  As Long
    End Type
    Public Type WIN32_FIND_DATA
        dwFileAttributes    As Long
        ftCreationTime      As FILETIME
        ftLastAccessTime    As FILETIME
        ftLastWriteTime     As FILETIME
        nFileSizeHigh       As Long
        nFileSizeLow        As Long
        dwReserved0         As Long
        dwReserved1         As Long
        cFileName           As String * 260
        cAlternate          As String * 14
    End Type
    Public Const XML_FILE       As Long = 1
    Public Const XML_OVERWRITE  As Long = 2
    Public Const vbXML          As String = "<?xml version=""1.0"" encoding=""windows-1252"" standalone=""yes"" ?>"
    Public Sub WriteFile(ByRef strPath As String, ByRef strData As String, Optional ByVal blnText As Boolean = False)
        '------------------------------------------------------------------
        'Purpose:   To write data to a file on disk. By default it writes
        '           in binary mode as it is faster (because it doesn't do
        '           any character translations)
        '
        'Params:
        '           strPath:    Path to file to write to
        '           strData:    Data to write to file
        '           blnText:    Write in text (true) or binary (false)
        '------------------------------------------------------------------
     
        Dim intFF       As Integer
     
        'Get an unused file handle
        intFF = FreeFile
     
        'Are we writing in text or binary mode?
        If blnText Then
            Open strPath For Output As intFF
        Else
            Open strPath For Binary Access Write As intFF
        End If
     
        'Print characters to file
        Put intFF, , strData
     
        'Close the file handle
        Close intFF
    End Sub
    Public Sub AppendFile(ByRef strPath As String, ByRef strData As String, Optional ByVal blnCR As Boolean = True)
        '------------------------------------------------------------------
        'Purpose:   To append data to a file. By default adds a carriage
        '           return to the end of the data
        '
        'Params:
        '           strPath:    Path to append to
        '           strData:    Data to append to file
        '           blnCR:      Add carriage return? (true to add)
        '------------------------------------------------------------------
     
        Dim intFF       As Integer
        'Get an unused file handle
        intFF = FreeFile
     
        'Open in Append mode
        Open strPath For Append As intFF
     
        'Print with carriage return by default, otherwise
        'print without
        If blnCR Then
            Print #intFF, strData
        Else
            Print #intFF, strData;
        End If
     
        'Close file handle
        Close intFF
    End Sub
    Public Sub DeleteFile(ByRef strPath As String)
        '------------------------------------------------------------------
        'Purpose:   Deletes a file on disk
        '
        'Params:
        '           strPath:    Path to file to be deleted
        '------------------------------------------------------------------
        On Error Resume Next
     
        'Delete the file! (that was easy =)
        Kill strPath
    End Sub
    Public Function ReadFile(ByRef strPath As String, Optional ByVal blnText As Boolean = False) As String
        '------------------------------------------------------------------
        'Purpose:   To read data from a file on disk. By default it reads
        '           in binary mode as it does no character translations
        '
        'Params:
        '           strPath:    Path to file to read
        '           blnText:    Read in text (true) or binary (false) mode
        '
        'Returns:   Data read from file
        '------------------------------------------------------------------
     
        Dim intFF       As Integer
        Dim i           As Long
        'Read only if the file exists
        If PathExists(strPath) Then
            'Get an unused file handle
            intFF = FreeFile
     
            'Are we reading in binary or in text mode?
            '(default is binary as it is faster)
            If blnText Then
                Open strPath For Input As intFF
            Else
                Open strPath For Binary Access Read As intFF
            End If
     
            'If length is zero, we don't need to read from the file
            i = LOF(intFF)
     
            'Assuming the file has content, prepare a buffer
            'and read data into that buffer
            If i Then
                ReadFile = Space$(i)
                Get intFF, , ReadFile
            End If
     
            'Close file handle
            Close intFF
        End If
    End Function
    Public Function PathExists(ByRef strPath As String) As Boolean
        '------------------------------------------------------------------
        'Purpose:   To determine if a path exists or not (works for both
        '           folders and files)
        '
        'Params:
        '           strPath:    Path to check for existence
        '
        'Returns:   True if it exists, false if not
        '------------------------------------------------------------------
        'API call returns -1 if the path is invalid
        PathExists = Not (GetFileAttributes(strPath) = -1)
    End Function
    Public Function TempFile() As String
        '------------------------------------------------------------------
        'Purpose:   To generate a path for a temporary file which is
        '           guarunteed not to be used by another process
        '
        'Returns:   Path to file
        '------------------------------------------------------------------
        Randomize GetTickCount
        'Keep looping until we find a file path which isn't used
        Do
            TempFile = App.Path & "\" & GetTickCount & Rnd & ".tmp"
        Loop While PathExists(TempFile)
    End Function
    Public Function XMLEscape(ByRef strData As String) As String
        '------------------------------------------------------------------
        'Purpose:   Converts characters that XML requires to be escaped
        '           into the proper escape sequence
        '
        'Params:
        '           strData:    String to search for characters to escape
        '                       in
        '
        'Returns:   String with necessary characters escaped
        '------------------------------------------------------------------
     
        XMLEscape = strData
     
        If LenB(XMLEscape) Then
            'Check for the illegal characters
            If InStrB(1, XMLEscape, "&") Then XMLEscape = Replace(XMLEscape, "&", "&amp;")
            If InStrB(1, XMLEscape, "<") Then XMLEscape = Replace(XMLEscape, "<", "&lt;")
            If InStrB(1, XMLEscape, ">") Then XMLEscape = Replace(XMLEscape, ">", "&gt;")
            If InStrB(1, XMLEscape, """") Then XMLEscape = Replace(XMLEscape, """", "&quot;")
            If InStrB(1, XMLEscape, "'") Then XMLEscape = Replace(XMLEscape, "'", "&apos;")
        End If
    End Function
    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, "&lt;") Then XMLUnescape = Replace(XMLUnescape, "&lt;", "<")
                    If InStrB(i, XMLUnescape, "&gt;") Then XMLUnescape = Replace(XMLUnescape, "&gt;", ">")
                    If InStrB(i, XMLUnescape, "&quot;") Then XMLUnescape = Replace(XMLUnescape, "&quot;", """")
                    If InStrB(i, XMLUnescape, "&apos;") Then XMLUnescape = Replace(XMLUnescape, "&apos;", "'")
                    If InStrB(i, XMLUnescape, "&amp;") Then XMLUnescape = Replace(XMLUnescape, "&amp;", "&")
                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
    
    Podes fazer o download do project sample aqui:
    http://www.megaupload.com/pt/?d=ZP3GGORE

    Compr.
     

Partilhar esta Página