קוד:
[ Make_XML("Employees","test") /CODE]
טבלת עובדים קובץ טסט
[CODE]
Sub Make_XML(strTableName As String, strFileName As String)
Dim db As DAO.Database, tdf As DAO.TableDef, fld As DAO.Field, rst As DAO.Recordset
Dim sText As String, lLineCount As Long, i As Integer
Dim SourcePath As String, N As Integer
Dim arrCount As Integer, nFileNum As Integer
On Error GoTo Fun_Err
Set db = CurrentDb()
Set tdf = db.TableDefs(strTableName)
arrCount = tdf.Fields.Count
ReDim arr(arrCount)
i = 0
For Each fld In tdf.Fields
arr(i) = fld.Name
i = i + 1
Next
strTableName = "SELECT * FROM " & strTableName
Set rst = CurrentDb.OpenRecordset(strTableName)
nFileNum = FreeFile
'=================== find the dir and root to a file
SourcePath = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
Open SourcePath & strFileName & ".xml" For Output Lock Read Write As nFileNum
Print #nFileNum, "<?xml version=" & """1.0""" & "encoding=" & """UTF-8""" & "?>"
Print #nFileNum, "<root>"
rst.MoveFirst
For N = 0 To rst.RecordCount
Do While Not rst.EOF
Print #nFileNum, vbTab & "<child>"
For i = 0 To arrCount - 1
Print #nFileNum, vbTab & vbTab & "<" & arr(i) & ">" & rst(i) & "</" & arr(i) & ">"
Next i
Print #nFileNum, vbTab & "</child>"
rst.MoveNext
Loop
Next N
Print #nFileNum, "</root>"
rst.Close
Set rst = Nothing
Set tdf = Nothing
Set db = Nothing
Fun_exit:
Close (nFileNum)
Exit Sub
Fun_Err:
' write error handler rutin
GoTo Fun_exit
End Sub