** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Tus Funciones Favoritas & Aportaciones & Artí­culos
  Mensajes nuevos Mensajes nuevos RSS - VBA: Access - XML - SAX. Muestreo
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoVBA: Access - XML - SAX. Muestreo

 Responder Responder
Autor
Mensaje
genoma111 Ver desplegable
Administrador
Administrador
Avatar

Unido: 28/Marzo/2011
Localización: ...
Estado: Sin conexión
Puntos: 3248
Enlace directo a este mensaje Tema: VBA: Access - XML - SAX. Muestreo
    Enviado: 09/Noviembre/2013 a las 11:50
Extrae una muestra del archivo xml, para su análisis. Útil para documentos gigantes.

Uso:

Private Sub Command0_Click()
    Dim strPath As String
    Dim strFile As String
    Dim strNode As String
    Dim lngTotN As Long
    Dim strOutF As String
   
    strPath = CurrentProject.Path
    strFile = "El archivo.xml"
    strNode = "El nodo 'Parent'"
    lngTotN = El número total de nodos ' p.e.: 219278
    strOutF = "El archivo de muestra.xml"
   
    Call SampleXml(strPath, strFile, strNode, lngTotN, strOutF)
End Sub

Módulo:

'-------------------------------------------------------------------------------------------
' Name:         SampleXML
' Purpose:      Llama a la clase clsSaxContentHandlerSampleXml.
' Description:  strPath = La ruta completa.
'               strFile = El nombre del archivo xml.
'               strNode = El nombre del nodo 'Parent'.
'               lngTotN = El número total de nodos "strNode" en el documento.
'               strOutF = El nombre del archivo de muestra.
' Author:       Diego F.Pereira-Perdomo
' Date:         Oct-28-2013
' References:   Requiere la librería Microsoft XML, v6.0
'               Requiere la clase clsSaxContentHandlerSampleXml
'               Requiere la función SampleSize
'               Requiere la función RandomNumbers
'-------------------------------------------------------------------------------------------
Option Compare Database
Option Explicit

Sub SampleXml(strPath As String, _
              strFile As String, _
              strNode As String, _
              lngTotN As Long, _
              strOutF As String)
             
    Const xmlHeading = "<?xml version='1.0' encoding='utf-8'?>"
    Const xmlFirst = "<root>"
    Const xmlLast = "</root>"
   
    Dim writer          As MXXMLWriter60
    Dim atrs            As SAXAttributes60
    Dim reader          As SAXXMLReader60
    Dim contentHandler  As clsSaxContentHandlerSampleXml
    Dim strPF           As String
    Dim fFile           As Long
   
    Set writer = New MXXMLWriter60
    Set atrs = New SAXAttributes60
    Set reader = New SAXXMLReader60
    Set contentHandler = New clsSaxContentHandlerSampleXml
    Set reader.contentHandler = contentHandler
    Set reader.errorHandler = contentHandler
    Set contentHandler.oContentHandler = writer
    Set contentHandler.oErrorHandler = writer
   
    writer.indent = True
    writer.standalone = True
    writer.output = ""
    writer.omitXMLDeclaration = True
    writer.byteOrderMark = True
   
    contentHandler.SetFilterCriteria (strNode)
    contentHandler.SetSubset (lngTotN)
   
    On Error GoTo HandleError
   
    strPath = strPath & "\"
    strPF = strPath & strFile
       
    reader.parseURL (strPF)
   
    fFile = FreeFile
   
    strPF = strPath & strOutF
   
    Open strPF For Output As #fFile
        Print #fFile, xmlHeading
        Print #fFile, xmlFirst
        Print #fFile, writer.output
        Print #fFile, xmlLast
    Close #fFile
   
    Set writer = Nothing
    Set atrs = Nothing
    Set reader = Nothing
    Set contentHandler = Nothing
    Set reader.contentHandler = Nothing
    Set reader.errorHandler = Nothing
    Set contentHandler.oContentHandler = Nothing
    Set contentHandler.oErrorHandler = Nothing

Exit Sub

HandleError:
    If Not contentHandler.errorHappen Then
        Debug.Print "**** Error **** " & Err.Number & " : " & Err.Description
    End If
End Sub

La clase clsSaxContentHandlerSampleXml:

'-------------------------------------------------------------------------------------------
' Name:         clsSaxContentHandlerSampleXml
' Purpose:      Extrae una muestra del documento xml basado en el nodo seleccionado.
' Author:       Diego F.Pereira-Perdomo
' Date:         Nov-08-2013
' References:   Requiere la librería Microsoft XML, v6.0
'               Requiere la función SampleSize
'               Requiere la función RandomNumbers
' Basado en el ejemplo "Create a Simple Filter" publicado en el msdn
' http://msdn.microsoft.com/en-us/library/ms759197%28v=vs.85%29.aspx
'-------------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
   
    Dim lngC    As Long
    Dim a
    Dim j       As Long

    Implements IVBSAXContentHandler
    Implements IVBSAXErrorHandler

    Public oContentHandler  As IVBSAXContentHandler
    Public oErrorHandler    As IVBSAXErrorHandler
    Public errorHappen      As Boolean

    Dim FilterTrue          As Boolean
    Dim FilterCriteria      As String
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_startDocument()
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_startPrefixMapping(strPrefix As String, _
                                                       strURI As String)
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_startElement(strNamespaceURI As String, _
                                                 strLocalName As String, _
                                                     strQName As String, _
                                            ByVal oAttributes As MSXML2.IVBSAXAttributes)

    Select Case strLocalName
   
        Case FilterCriteria
       
            lngC = lngC + 1
           
            If lngC = a(j) Then
                FilterTrue = True
            End If
           
    End Select
   
    If FilterTrue Then
   
        oContentHandler.startElement strNamespaceURI, _
                                     strLocalName, _
                                     strQName, _
                                     oAttributes
                                    
    End If

End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_characters(strChars As String)

    If FilterTrue Then
        oContentHandler.characters strChars
    End If
   
End Sub
'-------------------------------------------------------------------------------------------

Private Property Set IVBSAXContentHandler_documentLocator(ByVal RHS As MSXML2.IVBSAXLocator)
    Initialize
End Property
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_ignorableWhitespace(strChars As String)
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_processingInstruction(strTarget As String, _
                                                         strData As String)
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_skippedEntity(strName As String)
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_endElement(strNamespaceURI As String, _
                                               strLocalName As String, _
                                                   strQName As String)
    If FilterTrue Then
   
         oContentHandler.endElement strNamespaceURI, _
                                    strLocalName, _
                                    strQName
                                   
    End If
   
    Select Case strLocalName
   
        Case FilterCriteria
                   
            If lngC = a(j) Then
           
                FilterTrue = False
               
                If j < UBound(a) Then
                    j = j + 1
                End If
               
            End If
           
    End Select
   
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_endPrefixMapping(strPrefix As String)
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXContentHandler_endDocument()
'
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXErrorHandler_error(ByVal oLocator As MSXML2.IVBSAXLocator, _
                                    strErrorMessage As String, _
                                   ByVal nErrorCode As Long)

End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXErrorHandler_fatalError(ByVal oLocator As MSXML2.IVBSAXLocator, _
                                         strErrorMessage As String, _
                                        ByVal nErrorCode As Long)
                                       
    Debug.Print strErrorMessage & nErrorCode
    errorHappen = True
   
End Sub
'-------------------------------------------------------------------------------------------

Private Sub IVBSAXErrorHandler_ignorableWarning(ByVal oLocator As MSXML2.IVBSAXLocator, _
                                               strErrorMessage As String, _
                                              ByVal nErrorCode As Long)
End Sub
'-------------------------------------------------------------------------------------------

Public Sub SetFilterCriteria(elementname)

    FilterCriteria = elementname
   
End Sub
'-------------------------------------------------------------------------------------------

Private Sub Initialize()

    errorHappen = False
    FilterTrue = False
   
End Sub
'-------------------------------------------------------------------------------------------

Public Sub SetSubset(lngNodes As Long)

    Dim i As Long
    ' Calcula el tamaño de la muestra
    i = SampleSize(lngNodes)
    ' Genera números pseudo-aleatorios
    a = RandomNumbers(i, 1, lngNodes)
   
End Sub

Función SampleSize:

Option Compare Database
Option Explicit
'-------------------------------------------------------------------------------------------
' Name:         SampleSize
' Purpose:      Un método simple para calcular el tamaño de muestra.
' Description:  N = Número total de individuos o unidades en el estudio.
'               s = Desviación estándar (típica) poblacional.
'               Z = Valor crítico Z determinado por el nivel de confianza.
'               e = Error aceptable de muestreo.
' Author:       Diego F.Pereira-Perdomo
' Date:         Oct-27-2013
'-------------------------------------------------------------------------------------------
Function SampleSize(N As Long, _
           Optional s As Double = 0.5, _
           Optional Z As Double = 1.96, _
           Optional e As Double = 0.05) As Long
                   
    SampleSize = (N * (s ^ 2) * (Z ^ 2)) / ((N - 1) * (e ^ 2) + (s ^ 2) * (Z ^ 2))
   
End Function

Función RandomNumbers:

Option Compare Database
Option Explicit
'-------------------------------------------------------------------------------------------
' Name:         RandomNumbers
' Purpose:      Genera números pseudo-aleatorios y los almacena en un array
' Description:  lngA = Cantidad de números a ser generados.
'               lngL = Límite inferior.
'               lngU = Límite superior.
'               lngSeed = Opcional. Valor inicial a ser usado por Rnd.
' Author:       Diego F.Pereira-Perdomo
' Date:         Oct-27-2013
'-------------------------------------------------------------------------------------------
Function RandomNumbers(lngA As Long, _
                       lngL As Long, _
                       lngU As Long, _
           Optional lngSeed As Long = -0) As Variant
          
    Dim i       As Long
    Dim j       As Long
    Dim aRnd
   
    j = lngA - 1
    ReDim aRnd(j)
   
    If lngSeed = -0 Then
        For i = 0 To j
            aRnd(i) = Int((lngU - lngL + 1) * Rnd + lngL)
        Next i
    Else
        For i = 0 To j
            aRnd(i) = Int((lngU - lngL + 1) * Rnd(lngSeed) + lngL)
        Next i
    End If
   
    aRnd = BubbleSort(aRnd)
   
    RandomNumbers = aRnd

End Function
'-------------------------------------------------------------------------------------------

' Función orginal del msdn http://support.microsoft.com/kb/133135
Public Function BubbleSort(ByVal tempArray As Variant) As Variant
    Dim Temp        As Variant
    Dim i           As Integer
    Dim NoExchanges As Integer

    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
       
        ' Loop through each element in the array.
        For i = 0 To UBound(tempArray) - 1
       
            ' Substitution when element is greater than the element following int
            If tempArray(i) > tempArray(i + 1) Then
                NoExchanges = False
                Temp = tempArray(i)
                tempArray(i) = tempArray(i + 1)
                tempArray(i + 1) = Temp
            End If
       
        Next i
   
    Loop While Not (NoExchanges)
   
    BubbleSort = tempArray

End Function



Editado por genoma111 - 09/Noviembre/2013 a las 21:50
"To VBA or not to VBA... that's the question" DFP
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable