Extraer a XML Access (Tablas, Consultas, Reportes) desde codigo vba
*** EL CODIGO ***
Option Compare Database
Option Explicit
'***************************************************************
'& &*
'& &*
'& &*
'& &*
'& Jefferson Jimenez (JJJT) &*
'& Cabimas - Venezuela &*
'& Agosto - 2010 &*
'& &*
'& &*
'& &*
'& &*
'& &*
'***************************************************************
'Creo un Enum para elegir la estructura a exportar
Enum OutXML
acExportTable = 0
acExportQuery = 1
acExportForm = 2
acExportReport = 3
acExportFunction = 10
End Enum
Public Sub ExportaXML(BD_Origen As String, _
Destino_XML As String, _
Optional Objt As OutXML, _
Optional frm As Form, _
Optional Rpt As Report, _
Optional StrDataSource As String, _
Optional cRiTeRio As String)
On Error GoTo ExpXML_Err
Dim base As Database 'Variable para la BD (puede ser interna o externa)
Dim Tabla As TableDef 'Variable para la Busqueda de tablas
'dim Qry as QueryDef 'Tambien pudiesemos hacerlos para las consultas
Dim objAD As AdditionalData 'Representa la colección de tablas y consultas que se incluirá en la tabla primaria exportada por el método ExportXML
Set base = OpenDatabase(BD_Origen) 'Cargo la BD
Set objAD = Application.CreateAdditionalData 'Cargo la coleccion
'Segun sea el caso
Select Case Objt
Case 0
'Si el StrDataSource esta vacio, quiere decir que seran todas las tablas
If StrDataSource = "" Then
With objAD
For Each Tabla In base.TableDefs 'Recorro las tablas activas de la BD
'No exporto las del sistema y dejo de ultima la del Form Activo (Necesaria)
If Left$(Tabla.Name, 4) <> "Msys" And Tabla.Name <> frm.RecordSource Then
.Add Tabla.Name 'Me las cargo
End If
Next Tabla
base.Close 'Cierro
End With
'Exporto a XML agregando todas las tablas AdditionalData:=objAD
Application.ExportXML Objt, frm.RecordSource, _
Destino_XML, AdditionalData:=objAD
Else
'De exportar por aqui significa que sera una sola tabla a consulta
Application.ExportXML Objt, StrDataSource, Destino_XML
End If
Case 3
'De tratarse de un Reporte
Application.ExportXML Objt, Rpt.RecordSource, _
Destino_XML
Case 1
'Para exportar una consulta segun un filtro
Application.ExportXML Objt, StrDataSource, _
Destino_XML, , , , , , cRiTeRio
End Select
'Aviso si fue exitosa la exportacion
MsgBox "La Exportacion Fue Existosa" & vbCrLf & "Busque el Archivo XML en esta misma Carpeta", vbExclamation, "JJJT Access"
ExpXML_Exit:
Exit Sub
ExpXML_Err:
MsgBox Error$
Resume ExpXML_Exit
End Sub