First go with trying to import xml to a database and whilst i have
managed to do what i want i find that the xml files we have here at
work are gonna cause me problems. I have a function that imports any
aml file, at the moment its importing to a hardcoded (name only) table
but i can manage to work out how to take the xml file name and use that
for the table name. My problem is some of the xml files do not follow
the structural conventions that are in place at this office they should
be as below...
.....
<DATAPACKET Version="2.0">
<METADATA>
<FIELDS>
<FIELD attrname="ENG_ID" fieldtype="r8" />
<FIELD attrname="JOB_DATE" fieldtype="dateTime" />
....
Followed by all the rest of the field names and types
....
</FIELDS>
<PARAMS LCID="1033" />
</METADATA>
Then tha actual Data
<ROWDATA>
<ROW ENG_ID="45" JOB_DATE="20060329" ACTIVITY_ID="44" QTY="1"
DURATION="75" SENT="Y" />
....
....
</ROWDATA>
</DATAPACKET>
providing that the fields are listed in the top section my function
will create a new table and populate it with the firlds and data from
the xml.
However some xml files have missing field data in the top or bottom
section ie a fiels is listed in the <fields> section but there is
nothing in the <rowdata> and vice versa. Guys this is so my first go
at this and ive struggled to get this far can anyone point me in the
right direction of how to get round this. Plus if theres anything in
the function that could be improved tell me. I could use the lessons. (
hopes there are no KIng Black Dragons lurking to flame a dumb nub)
antway heres the function and ty in anticipation
Private Function ProcessSingleProblemXML(ByVal sFile As String) As
Boolean
On Error Resume Next
Dim objDomDoc As New DOMDocument
Dim objRoot As IXMLDOMNode
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim child As IXMLDOMNode
Dim c As Integer
Dim r As Integer
Dim Maxc As Integer
Dim Maxr As Integer
Dim FieldNames() As String
Dim FieldType() As String
Dim Records() As String
Dim tdfNew As TableDef
Dim strField As String
Dim strFieldType As String
Dim fldNew As Field
Set dbs = CurrentDb
sFile = cXML_File_Folder & sFile
'If Dir(sFile) = "" Then Exit Function
objDomDoc.async = False
objDomDoc.Load sFile
Set objRoot = objDomDoc.documentElement
'Get No of Records (sure that there is a better way)
Maxr = 0
Maxc = 0
For Each child In objRoot.childNodes(1).childNodes
Maxr = Maxr + 1
Next
For Each child In objRoot.childNodes(0).childNodes(0).childNodes
Maxc = Maxc + 1
Next
Maxc = Maxc - 1
Maxr = Maxr - 1
ReDim FieldNames(Maxc)
ReDim FieldType(Maxc)
ReDim Records(Maxc, Maxr)
'Create fieldname array
c = 0
For Each child In objRoot.childNodes(0).childNodes(0).childNodes
FieldNames(c) = child.Attributes.getNamedItem("attrname").nodeValu e
FieldType(c) = child.Attributes.getNamedItem("fieldtype").nodeVal ue
c = c + 1
Next
'Initialise rowdata array
'Add rowdata to Records Array
c = 0
Do While c <= Maxc
r = 0
For Each child In objRoot.childNodes(1).childNodes
Records(c, r) =
child.Attributes.getNamedItem(FieldNames(c)).nodeV alue
r = r + 1
Next
c = c + 1
Loop
'Create table starts here
Set dbs = CurrentDb
On Error Resume Next
DoCmd.DeleteObject acTable, "MyNewTable1"
On Error GoTo 0
Set tdfNew = dbs.CreateTableDef("MyNewTable1")
c = 0
Do While c <= Maxc
strField = FieldNames(c)
strFieldType = FieldType(c)
Select Case strFieldType
Case "r8"
Set fldNew = tdfNew.CreateField(strField, dbText, 50)
Case "dateTime"
Set fldNew = tdfNew.CreateField(strField, dbText, 50)
Case "string"
Set fldNew = tdfNew.CreateField(strField, dbText, 50)
End Select
tdfNew.Fields.Append fldNew
c = c + 1
Loop
dbs.TableDefs.Append tdfNew
Set tdfNew = Nothing
Set fldNew = Nothing
'End Create table works up to here
Set rst = dbs.OpenRecordset("MyNewTable1")
r = 0
For r = 0 To Maxr
c = 0
rst.AddNew
For c = 0 To Maxc
If Records(c, r) <> "1" Then
rst.Fields(FieldNames(c)) = Records(c, r)
Else
rst.Fields(FieldNames(c)) = "N/A"
End If
Next
rst.Update
Next
rst.Close
'If unable to read xml store a detail of why
If Err.Number = 91 Then
Set rst = dbs.OpenRecordset("FIL_IMPRT_ERRRS", dbOpenDynaset)
rst.AddNew
rst!TYP = "PRBLM"
rst!BAD_FIL_NM = Replace(sFile, "Problem", "Reject")
rst!ERRR_DAT = Now()
rst.Update
rst.Close
Set rst = Nothing
ProcessSingleProblemXML = False
Exit Function
Else
ProcessSingleProblemXML = True
End If
'On Succcess exit function
If Err.Number = 0 Then ProcessSingleProblemXML = True
'Clean up
Set rst = Nothing
Set dbs = Nothing
Set objDomDoc = Nothing
End Function
