UtterAccess HomeUtterAccess Wiki

Welcome Guest ( Log In | Register )

Custom Search
Edit Discussion
> QxXML    
CODE

'---------------------------------------------------------------------------------------------------------------------------------------
' qxXML
' http://www.utteraccess.com/wiki/index.php/FunctionNameHere
' Code courtesy of UtterAccess Wiki
' Original submission by Diego F.Pereira-Perdomo
' Licensed under Creative Commons License
' http://creativecommons.org/licenses/by-sa/3.0/
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
' rev  date                          brief descripton
' 1.0  2012-07-10                    Exports Cross-tab queries with more than 255 fields, preserving datatypes and column order.
'
'                                       By using xsd and xml files exports cross-tab queries to Excel.
'
'                                       qry:          Name of the query
'                                       idF:          Name of the ID field
'                                       colN:         Name of the field that contains the names of the column headings.
'                                       valueF:       Name of the field that contains the aggregated values.
'                                       FileN:        Name of the field that contains the name of the xlsx file to be created.
'                                                     Can be a calculated field in the query, i.e. MyFile: "xyx"
'                                       orderF:       Optional.
'                                                     Name of the field that contains the order (a number) of the columns.
'                                       Requires:     ToXmlHex, ToFileName, XsdCTSequence, XlmFile and XmlToXls functions
'
'                                       Use:          qxXML "Query", "ID", "Column", "Values", "FileName", "Order"
'---------------------------------------------------------------------------------------------------------------------------------------

Public Function qxXML(qry As String, _
                     idF As String, _
                    colN As String, _
                  valueF As String, _
                   FileN As String, _
         Optional orderF As String = "") As String

On Error GoTo ErrorHandler

Dim dbs         As DAO.Database
Dim rstSql1     As DAO.Recordset
Dim rstSql2     As DAO.Recordset
Dim rstSql3     As DAO.Recordset

Dim strSql1     As String
Dim strSql2     As String
Dim strSql3     As String
Dim strSqlD     As String

Dim strRowF     As String
Dim strColF     As String

Dim strPath     As String
Dim strFile     As String
Dim strFileN    As String
Dim strXsdPath  As String
Dim strXmlPath  As String
Dim strXlsPath  As String

Dim a           As Integer
Dim i           As Integer

Dim strElX      As String
Dim strRwX      As String
Dim strCVX      As String
Dim strChild    As String


   Set dbs = CurrentDb
   
   strPath = CurrentProject.Path & "\"
   
   strSql1 = " SELECT DISTINCT " & FileN & _
           " FROM " & qry
   
   Set rstSql1 = dbs.OpenRecordset(strSql1)
   
   With rstSql1
       If (Not .EOF) And (Not .BOF) Then
           Do While Not .EOF
               strFileN = Left(rstSql1(FileN), InStr(1, rstSql1(FileN), ".") - 1)
               strFileN = ToFileName(strFileN)
'---------------------------------------------------------------------------------------------------------------------------------------
' XSD File (XML Schema)
'---------------------------------------------------------------------------------------------------------------------------------------

               ' Build the XSD File Elements

               ' This SQL captures just the field names and datatypes of the query fields.

   
               strSql2 = " SELECT TOP 1 *" & _
                       " FROM " & qry
   
               Set rstSql2 = dbs.OpenRecordset(strSql2)
   
               With rstSql2
   
                   a = .Fields.Count - 1
   
                   ' Loop through the "row" fields of the aggregate query.
                   ' colN ("column" field), valueF("value" field) and orderF are not included here.
   
                   For i = 0 To a
                       If .Fields(i).Name <> colN And _
                           .Fields(i).Name <> orderF And _
                           .Fields(i).Name <> valueF Then
   
                           ' Translates the complete string to its equivalent Hex entity "_x###$_"
   
                           strRowF = .Fields(i).Name
                           strRowF = ToXmlHex(strRowF)
   
                           ' Writes the field name of the "row" fields according to their datatype.
   
                           Select Case True
                               Case .Fields(i).Type = 7 ' dbdouble
                               
                                   strElX = "<xsd:element name='" & strRowF & "' " & _
                                            "minOccurs='0' " & _
                                            "od:jetType='double' " & _
                                            "od:sqlSType='float' " & _
                                            "type='xsd:double'/>" & _
                                   vbCrLf
                                           
                               Case .Fields(i).Type = 4 ' dbLong
                               
                                   strElX = "<xsd:element name='" & strRowF & "' " & _
                                            "minOccurs='0' " & _
                                            "od:jetType='longinteger' " & _
                                            "od:sqlSType='int' " & _
                                            "type='xsd:int'/>" & _
                                   vbCrLf
                                           
                               Case .Fields(i).Type = 8 ' dbDate
                               
                                   strElX = "<xsd:element name='" & strRowF & "' " & _
                                            "minOccurs='0' " & _
                                            "od:jetType='datetime' " & _
                                            "od:sqlSType='datetime' " & _
                                            "type='xsd:dateTime'/>" & _
                                   vbCrLf
                                           
                               Case .Fields(i).Type = 12 ' dbMemo
                               
                                   strElX = "<xsd:element name='" & strRowF & "' " & _
                                            "minOccurs='0' " & _
                                            "od:jetType='memo' " & _
                                            "od:sqlSType='ntext'/>" & _
                                   vbCrLf
                                           
                               Case .Fields(i).Type = 10 ' dbText
                               
                                   strElX = "<xsd:element name='" & strRowF & "' " & _
                                            "minOccurs='0' " & _
                                            "od:jetType='text' " & _
                                            "od:sqlSType='nvarchar'/>" & _
                                   vbCrLf
                                           
                           End Select
                           
                           ' Complete "rows" String
                           
                           strRwX = strRwX & strElX
                           
                           ' Pass the field names to a variable that will be used in the strSql2 query
                           ' when building the XML file.
   
                           If i < a Then
                               strSqlD = strSqlD & "[" & .Fields(i).Name & "], "
                           Else
                               strSqlD = strSqlD & "[" & .Fields(i).Name & "]"
                           End If
                       End If
                   Next i
                   
                   strSqlD = Trim(strSqlD)
                   
                   If Right$(strSqlD, 1) = "," Then
                      strSqlD = Left$(strSqlD, Len(strSqlD) - 1)
                   End If

               End With
   
               ' Capture the colN field, ordering the results according to the orderF field if it was included.
               
               If Nz(orderF, "") <> "" Then
               
                   strSql3 = " SELECT DISTINCT " & colN & ", " & orderF & _
                           " FROM " & qry & _
                           " WHERE " & FileN & "='" & rstSql1(FileN) & "'" & _
                           " ORDER BY " & orderF
               Else
                   strSql3 = " SELECT DISTINCT " & colN & _
                           " FROM " & qry & _
                           " WHERE " & FileN & "='" & rstSql1(FileN) & "'"
               End If

               Set rstSql3 = dbs.OpenRecordset(strSql3)
   
                ' Loop through all the records related with the FileN field.
   
               With rstSql3
                   If (Not .EOF) And (Not .BOF) Then
                       Do Until .EOF
   
                           ' Translates the complete string to its equivalent Hex entity "_x###$_"
                           ' and removes leading and trailing spaces.
   
                           strColF = Nz(Trim(rstSql3(colN)))
   
                           ' Exclude empty fields
   
                           If Len(strColF) <> 0 Then
                               strColF = ToXmlHex(strColF)
   
                               ' Capture the colN value for using it as a heading.
                               ' The datatype is double since it will contain the aggregate values.
   
                               strCVX = strCVX & _
                                               "<xsd:element name='" & strColF & "' " & _
                                               "minOccurs='0' " & _
                                               "od:jetType='double' " & _
                                               "od:sqlSType='float' " & _
                                               "type='xsd:double'/>" & _
                                        vbCrLf
                           End If
                           .MoveNext
                       Loop
                   End If
               End With
               
               strChild = strRwX & strCVX
               
               ' Name of the XSD file.
               
               strFile = strFileN & ".xsd"
               strXsdPath = strPath & strFile
   
               ' Send the Child elements to the XsdCTSequence function
   
               XsdCTSequence strChild, strXsdPath, strFileN
               
               ' Partial cleaning
               
               strElX = ""
               strRwX = ""
               strCVX = ""
               strChild = ""
               
               rstSql2.Close
               rstSql3.Close
   
               Set rstSql2 = Nothing
               Set rstSql3 = Nothing
   
'---------------------------------------------------------------------------------------------------------------------------------------
' XML File
'---------------------------------------------------------------------------------------------------------------------------------------
   
               ' This SQL captures the "row" fields of the aggregate query.
   
               strSql2 = " SELECT DISTINCT " & strSqlD & _
                       " FROM " & qry & _
                       " WHERE " & FileN & "='" & rstSql1(FileN) & "'"

               Set rstSql2 = dbs.OpenRecordset(strSql2)
   
               With rstSql2
   
                   a = .Fields.Count - 1
   
                   If (Not .EOF) And (Not .BOF) Then
                       Do While Not .EOF
                       
                           ' Start tag of the XML "row"
                           
                           strChild = strChild & _
                                               "<" & strFileN & ">" & _
                                      vbCrLf
   
                           ' Loop through the fields.
   
                           For i = 0 To a
   
                               strRowF = .Fields(i).Name
                               strRowF = ToXmlHex(strRowF)
   
                               ' Writes the field names and corresponding values into the XML file.
                               ' Note that CDATA is used in order to avoid errors related with the XML parser.
   
                               strChild = strChild & _
                                                   "<" & strRowF & ">" & _
                                                   "<![CDATA[" & .Fields(i) & "]]>" & _
                                                   "</" & strRowF & ">" & _
                                          vbCrLf
   
                           Next i
   
                           ' This SQL captures the "column" and "value" fields.
   
                           strSql3 = " SELECT " & colN & ", " & valueF & _
                                   " FROM " & qry & _
                                   " WHERE " & FileN & "='" & rstSql1(FileN) & "'"
                                   
                                   ' Inspects the datatype of the ID field and completes the SQL string
                                   
                                   Select Case rstSql2(idF).Type
                                   
                                       Case 10 ' dbText
                                       
                                           strSql3 = strSql3 & " AND " & idF & "='" & rstSql2(idF) & "'"
                                           
                                       Case 3, 4, 7 ' dbInteger, dbLong, dbDouble
                                       
                                           strSql3 = strSql3 & " AND " & idF & "=" & rstSql2(idF)
                                           
                                       Case 8 ' dbDate
                                       
                                           strSql3 = strSql3 & " AND " & idF & "=#" & rstSql2(idF) & "#"
                                           
                                   End Select
   
                           Set rstSql3 = dbs.OpenRecordset(strSql3)
   
                           ' Loop through all the colN and valF records related with idF and FileN.
   
                           With rstSql3
                               If (Not .EOF) And (Not .BOF) Then
                                   Do Until .EOF
   
                                       ' Translates the complete string to its equivalent Hex entity "_x###$_"
                                       ' and removes trailing spaces and fixes the errors when colN is Null.
   
                                       strColF = Nz(Trim(rstSql3(colN)))
   
                                       ' Exclude empty fields.
   
                                       If Len(strColF) <> 0 Then
   
                                           strColF = ToXmlHex(strColF)
   
                                           ' Cross-tabbed columns and values.
   
                                           strChild = strChild & _
                                                               "<" & strColF & ">" & _
                                                               rstSql3(valueF) & _
                                                               "</" & strColF & ">" & _
                                                      vbCrLf
   
                                       End If

                                       .MoveNext
                                   Loop
                               End If
                           End With
                           
                           ' End tag of the XML "row"
                           
                           strChild = strChild & _
                                               "</" & strFileN & ">" & _
                                      vbCrLf
                           .MoveNext
                       Loop
                   End If
               End With
               
               ' Name of the XML file
               
               strFile = strFileN & ".xml"
               strXmlPath = strPath & strFile
               
               ' Send the Child elements to the XlmFile function
   
               XlmFile strChild, strXmlPath, strXsdPath
               
               ' Parcial cleaning
               
               strChild = ""
   
               rstSql2.Close
               rstSql3.Close
   
               Set rstSql2 = Nothing
               Set rstSql3 = Nothing
   
'---------------------------------------------------------------------------------------------------------------------------------------
' EXCEL File (.xlsx)
'---------------------------------------------------------------------------------------------------------------------------------------
   
               ' Name of the Excel file
   
               strXlsPath = strPath & strFileN & ".xlsx"
   
               ' Imports the XML file to Excel using the XmlToXls function.
   
               XmlToXls strXmlPath, strXlsPath
   
               Kill (strXsdPath) ' <-- Deletes the XSD file
               Kill (strXmlPath) ' <-- Deletes the XML file
   
               DoEvents
               
               strSqlD = ""
               
               .MoveNext
           Loop
       End If
   
   End With
   
   ' Final cleaning

   MsgBox "Done"
   
ExitFunction:

Set rstSql3 = Nothing
Set rstSql2 = Nothing
Set rstSql1 = Nothing
Set dbs = Nothing
Exit Function

ErrorHandler:
Select Case Err.Number
   Case 0
   Case 94
       MsgBox Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & _
               "Please check the name and order of the fields included in the function" & vbCrLf & vbCrLf & _
               "qry:        Name of the query." & vbCrLf & _
               "idF:        Name of the ID field." & vbCrLf & _
               "colN:     Name of the field that contains the names of the column headings." & vbCrLf & _
               "valueF:  Name of the field that contains the aggregated values." & vbCrLf & _
               "FileN:    Name of the field that contains the name of the xlsx file to be created." & vbCrLf & _
               "              Can be a calculated field in the query" & vbCrLf & _
               "              i.e. MyFile: 'xyx'." & vbCrLf & _
               "orderF:  Optional." & vbCrLf & _
               "              Name of the field that contains the order (a number) of the columns."
   Case Else
       MsgBox Err.Number & ": " & Err.Description
       Resume ExitFunction
End Select
 
End Function

Creative Commons License
QxXML by UtterAccess Wiki is licensed under a Creative Commons Attribution-ShareAlike 3.0 Unported License.
Editing and revision of the content is freely encouraged; for details, see Expected Usage.

Edit Discussion
Custom Search
Thank you for your support!
This page has been accessed 2,107 times.  This page was last modified 07:10, 10 July 2012 by dipetete.   Disclaimers