AccessToXML

Private Sub CreateXML()
    Dim intTableCount As Integer
    If Len(Dir(strXMLLocation)) > 1 Then Kill strXMLLocation
    
    Open strXMLLocation For Output As #1
    Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>"
    Print #1, "<" & UCase(strDBName) & ">"
    intTableCount = 0
    intTableCount = catDB.Tables.Count
    For intCounter1 = 0 To intTableCount - 1
        With catDB
            If (.Tables(intCounter1).Type = "TABLE") Then
                
                intTableCount = intTableCount + 1
                
                If (trvMain.Nodes("T" & Trim(intTableCount)).Checked) Then
                    
                    Set rstTable = New ADODB.Recordset
                    rstTable.Open "SELECT * FROM " & Trim(.Tables(intCounter1).Name), _
                                  dbConnect, adOpenForwardOnly
                    
                    Print #1, "     <" & UCase(Trim(.Tables(intCounter1).Name)) & ">"
                    
                    If (Not rstTable.EOF) And (Not rstTable.BOF) Then
                        
                        rstTable.MoveFirst
                        
                        Do While Not rstTable.EOF
                            
                            Print #1, "          <RECORD>"
                            
                            intFieldCount = rstTable.Fields.Count
                            
                            For intCounter2 = 0 To intFieldCount - 1
                                If trvMain.Nodes("T" & Trim(intTableCount) & "F" & Trim(intCounter2)).Checked Then
                                    
                                    With rstTable.Fields(intCounter2)
                                        If (.Type = 202) Or (.Type = 203) Then
                                            Print #1, "               <" & UCase(Trim(.Name)) & " Type= '" & Trim(GetType(.Type)) & "'>"
                                            Print #1, "               " & .Value
                                            Print #1, "               </" & UCase(Trim(.Name)) & ">"
                                        ElseIf Trim(GetType(.Type)) = "Unknown" Then
                                            Print #1, "               <" & UCase(Trim(.Name)) & " Type= 'Unknown'> </" & UCase(Trim(.Name)) & ">"
                                        ElseIf .Type <> 205 Then
                                            Print #1, "               <" & UCase(Trim(.Name)) & " Type= '" & Trim(GetType(.Type)) & "'> " & .Value & _
                                                " </" & UCase(Trim(.Name)) & ">"
                                        End If
                                    End With
                                    
                                End If
                            Next intCounter2
                            Print #1, "          </RECORD>"
                            rstTable.MoveNext
                        Loop
                    End If
                    
                    Print #1, "     </" & UCase(Trim(.Tables(intCounter1).Name)) & ">"
                End If
            End If
        End With
        Set rstTable = Nothing
    Next intCounter1
    Print #1, "</" & UCase(strDBName) & ">"
    Close
End Sub

Private Sub Form_Load()
    mnuCompile.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set rstTable = Nothing
    Set catDB = Nothing
    Set dbConnect = Nothing
End Sub

Private Sub mnuCompile_Click()
    CreateXML
    LoadXMLFile
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuLoad_Click()
    On Error GoTo ErrHandle
    Dim strXMLName As String
    
    With cdcMain
        .Flags = cdlOFNFileMustExist & cdlOFNHideReadOnly
        .CancelError = True
        .Filter = "MS Access DB Files|*.MDB|"
        .ShowOpen
        strDBLocation = .FileName
        strDBName = .FileTitle
    End With
    
    strXMLName = InputBox("What would you like to name the XML file?", "XML Name")
    
    If Trim(Len(strXMLName)) = 0 Then Exit Sub
    
    If UCase(Right(strXMLName, 4)) <> ".XML" Then strXMLName = strXMLName & ".xml"
    
    strXMLLocation = Replace(strDBLocation, strDBName, strXMLName)
    
    strDBName = Replace(UCase(strDBName), ".MDB", "")
    
    Populate_TreeView
    
    mnuCompile.Enabled = True
    
    Exit Sub
    ErrHandle:
    If Err.Number = 32755 Then
        Exit Sub
    Else
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
        Unload Me
    End If
End Sub

Private Sub Populate_TreeView()
    Dim intTableCount As Integer
    Dim nodNode As Node
    Set dbConnect = New ADODB.Connection
    dbConnect.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0"
    dbConnect.Open strDBLocation
    Set catDB.ActiveConnection = dbConnect
    
    trvMain.Nodes.Clear
    
    intTableCount = 0
    intTableCount = catDB.Tables.Count
    For intCounter1 = 0 To intTableCount - 1
        With catDB
            If .Tables(intCounter1).Type = "TABLE" Then
                
                intTableCount = intTableCount + 1
                
                Set nodNode = trvMain.Nodes.Add(, , "T" & Trim(intTableCount), Trim(.Tables(intCounter1).Name))
                trvMain.Nodes("T" & Trim(intTableCount)).Checked = True
                
                Set rstTable = New ADODB.Recordset
                rstTable.Open "SELECT * FROM " & Trim(.Tables(intCounter1).Name), dbConnect
                
                intFieldCount = rstTable.Fields.Count
                
                For intCounter2 = 0 To intFieldCount - 1
                    Set nodNode = trvMain.Nodes.Add("T" & _
                        Trim(intTableCount), tvwChild, _
                        "T" & Trim(intTableCount) & "F" & _
                        Trim(intCounter2), Trim(rstTable.Fields(intCounter2).Name))
                    trvMain.Nodes.Item("T" & Trim(intTableCount) & "F" & Trim(intCounter2)).Checked = True
                Next intCounter2
                
            End If
        End With
    Next intCounter1
    
End Sub

Private Sub LoadXMLFile()
    Dim lngLastPos As Long
    Dim lngLength As Long
    rtfMain.Text = ""
    rtfMain.SelColor = vbBlack
    rtfMain.SelBold = True
    
    rtfMain.LoadFile strXMLLocation, 1
    
    rtfMain.Span ("<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>")
    lngLastPos = rtfMain.SelLength - 1
    rtfMain.SelColor = vbBlue
    rtfMain.SelBold = False
    
    Do While lngLastPos > -1
        lngLastPos = rtfMain.Find("<", lngLastPos + 1)
        If lngLastPos = -1 Then Exit Do
        rtfMain.SelColor = vbBlue
        rtfMain.SelBold = False
        
        lngLength = (rtfMain.Find(">", lngLastPos)) - lngLastPos
        rtfMain.SelStart = lngLastPos + 1
        rtfMain.SelLength = lngLength
        rtfMain.SelColor = &HC0&
        rtfMain.SelBold = False
    Loop
    
    lngLastPos = 0
    
    Do While lngLastPos > -1
        lngLastPos = rtfMain.Find(">", lngLastPos + 1)
        rtfMain.SelColor = vbBlue
        rtfMain.SelBold = False
    Loop
    
    lngLastPos = 0
    
    Do While lngLastPos > -1
        lngLastPos = rtfMain.Find("</", lngLastPos + 1)
        rtfMain.SelColor = vbBlue
        rtfMain.SelBold = False
    Loop
    
    lngLastPos = 0
    
    Do While lngLastPos > -1
        lngLastPos = rtfMain.Find("=", lngLastPos + 1)
        rtfMain.SelColor = vbBlue
        rtfMain.SelBold = False
    Loop
    
    lngLastPos = 0
    
    Do While lngLastPos > -1
        lngLastPos = rtfMain.Find("'", lngLastPos + 1)
        rtfMain.SelColor = vbBlue
        rtfMain.SelBold = False
        
        If lngLastPos = -1 Then Exit Do
        lngLength = lngLastPos
        lngLastPos = rtfMain.Find("'", lngLastPos + 1)
        
        rtfMain.SelStart = lngLength + 1
        rtfMain.SelLength = (lngLastPos - lngLength) - 1
        rtfMain.SelColor = &H8000&
        rtfMain.SelBold = True
    Loop
    
    lngLastPos = 0
    
    Do While lngLastPos > -1
        lngLastPos = rtfMain.Find("'", lngLastPos + 1)
        rtfMain.SelColor = vbBlue
        rtfMain.SelBold = False
    Loop
    
    rtfMain.SelStart = 0
    rtfMain.SetFocus
End Sub

Option Explicit
Dim dbConnect As ADODB.Connection
Dim catDB As New ADOX.Catalog
Dim strDBLocation As String
Dim strDBName As String
Dim strXMLLocation As String
Dim intTableCount As Integer
Dim intFieldCount As Integer
Dim intCounter1 As Integer
Dim intCounter2 As Integer
Dim rstTable As ADODB.Recordset
Private Function GetType(intType As Integer) As String
Select Case intType
Case 2
GetType = "Integer"
Case 3
GetType = "Long Ineger"
Case 4
GetType = "Single"
Case 5
GetType = "Double"
Case 6
GetType = "Currency"
Case 7
GetType = "Date/Time"
Case 11
GetType = "Yes/No"
Case 17
GetType = "Byte"
Case 72
GetType = "Replication ID"
Case 202
GetType = "Text"
Case 203
GetType = "Memo"
Case 205
GetType = "OLE Object"
Case Else
GetType = "Unknown"

End Select

End Function

Private Sub CreateXML()
Dim intTableCount As Integer
If Len(Dir(strXMLLocation)) > 1 Then Kill strXMLLocation

Open strXMLLocation For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>"
Print #1, "<" & UCase(strDBName) & ">"
intTableCount = 0
intTableCount = catDB.Tables.Count
For intCounter1 = 0 To intTableCount - 1
With catDB
If (.Tables(intCounter1).Type = "TABLE") Then

intTableCount = intTableCount + 1

If (trvMain.Nodes("T" & Trim(intTableCount)).Checked) Then

Set rstTable = New ADODB.Recordset
rstTable.Open "SELECT * FROM " & Trim(.Tables(intCounter1).Name), _
dbConnect, adOpenForwardOnly

Print #1, " <" & UCase(Trim(.Tables(intCounter1).Name)) & ">"

If (Not rstTable.EOF) And (Not rstTable.BOF) Then

rstTable.MoveFirst

Do While Not rstTable.EOF

Print #1, " <RECORD>"

intFieldCount = rstTable.Fields.Count

For intCounter2 = 0 To intFieldCount - 1
If trvMain.Nodes("T" & Trim(intTableCount) & "F" & Trim(intCounter2)).Checked Then

With rstTable.Fields(intCounter2)
If (.Type = 202) Or (.Type = 203) Then
Print #1, " <" & UCase(Trim(.Name)) & " Type= '" & Trim(GetType(.Type)) & "'>"
Print #1, " " & .Value
Print #1, " </" & UCase(Trim(.Name)) & ">"
ElseIf Trim(GetType(.Type)) = "Unknown" Then
Print #1, " <" & UCase(Trim(.Name)) & " Type= 'Unknown'> </" & UCase(Trim(.Name)) & ">"
ElseIf .Type <> 205 Then
Print #1, " <" & UCase(Trim(.Name)) & " Type= '" & Trim(GetType(.Type)) & "'> " & .Value & _
" </" & UCase(Trim(.Name)) & ">"
End If
End With

End If
Next intCounter2
Print #1, " </RECORD>"
rstTable.MoveNext
Loop
End If

Print #1, " </" & UCase(Trim(.Tables(intCounter1).Name)) & ">"
End If
End If
End With
Set rstTable = Nothing
Next intCounter1
Print #1, "</" & UCase(strDBName) & ">"
Close
End Sub

Private Sub Form_Load()
mnuCompile.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set rstTable = Nothing
Set catDB = Nothing
Set dbConnect = Nothing
End Sub

Private Sub mnuCompile_Click()
CreateXML
LoadXMLFile
End Sub

Private Sub mnuExit_Click()
Unload Me
End Sub

Private Sub mnuLoad_Click()
On Error GoTo ErrHandle
Dim strXMLName As String

With cdcMain
.Flags = cdlOFNFileMustExist & cdlOFNHideReadOnly
.CancelError = True
.Filter = "MS Access DB Files|*.MDB|"
.ShowOpen
strDBLocation = .FileName
strDBName = .FileTitle
End With

strXMLName = InputBox("What would you like to name the XML file?", "XML Name")

If Trim(Len(strXMLName)) = 0 Then Exit Sub

If UCase(Right(strXMLName, 4)) <> ".XML" Then strXMLName = strXMLName & ".xml"

strXMLLocation = Replace(strDBLocation, strDBName, strXMLName)

strDBName = Replace(UCase(strDBName), ".MDB", "")

Populate_TreeView

mnuCompile.Enabled = True

Exit Sub
ErrHandle:
If Err.Number = 32755 Then
Exit Sub
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Unload Me
End If
End Sub

Private Sub Populate_TreeView()
Dim intTableCount As Integer
Dim nodNode As Node
Set dbConnect = New ADODB.Connection
dbConnect.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0"
dbConnect.Open strDBLocation
Set catDB.ActiveConnection = dbConnect

trvMain.Nodes.Clear

intTableCount = 0
intTableCount = catDB.Tables.Count
For intCounter1 = 0 To intTableCount - 1
With catDB
If .Tables(intCounter1).Type = "TABLE" Then

intTableCount = intTableCount + 1

Set nodNode = trvMain.Nodes.Add(, , "T" & Trim(intTableCount), Trim(.Tables(intCounter1).Name))
trvMain.Nodes("T" & Trim(intTableCount)).Checked = True

Set rstTable = New ADODB.Recordset
rstTable.Open "SELECT * FROM " & Trim(.Tables(intCounter1).Name), dbConnect

intFieldCount = rstTable.Fields.Count

For intCounter2 = 0 To intFieldCount - 1
Set nodNode = trvMain.Nodes.Add("T" & _
Trim(intTableCount), tvwChild, _
"T" & Trim(intTableCount) & "F" & _
Trim(intCounter2), Trim(rstTable.Fields(intCounter2).Name))
trvMain.Nodes.Item("T" & Trim(intTableCount) & "F" & Trim(intCounter2)).Checked = True
Next intCounter2

End If
End With
Next intCounter1

End Sub

Private Sub LoadXMLFile()
Dim lngLastPos As Long
Dim lngLength As Long
rtfMain.Text = ""
rtfMain.SelColor = vbBlack
rtfMain.SelBold = True

rtfMain.LoadFile strXMLLocation, 1

rtfMain.Span ("<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>")
lngLastPos = rtfMain.SelLength - 1
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False

Do While lngLastPos > -1
lngLastPos = rtfMain.Find("<", lngLastPos + 1)
If lngLastPos = -1 Then Exit Do
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False

lngLength = (rtfMain.Find(">", lngLastPos)) - lngLastPos
rtfMain.SelStart = lngLastPos + 1
rtfMain.SelLength = lngLength
rtfMain.SelColor = &HC0&
rtfMain.SelBold = False
Loop

lngLastPos = 0

Do While lngLastPos > -1
lngLastPos = rtfMain.Find(">", lngLastPos + 1)
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False
Loop

lngLastPos = 0

Do While lngLastPos > -1
lngLastPos = rtfMain.Find("</", lngLastPos + 1)
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False
Loop

lngLastPos = 0

Do While lngLastPos > -1
lngLastPos = rtfMain.Find("=", lngLastPos + 1)
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False
Loop

lngLastPos = 0

Do While lngLastPos > -1
lngLastPos = rtfMain.Find("'", lngLastPos + 1)
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False

If lngLastPos = -1 Then Exit Do
lngLength = lngLastPos
lngLastPos = rtfMain.Find("'", lngLastPos + 1)

rtfMain.SelStart = lngLength + 1
rtfMain.SelLength = (lngLastPos - lngLength) - 1
rtfMain.SelColor = &H8000&
rtfMain.SelBold = True
Loop

lngLastPos = 0

Do While lngLastPos > -1
lngLastPos = rtfMain.Find("'", lngLastPos + 1)
rtfMain.SelColor = vbBlue
rtfMain.SelBold = False
Loop

rtfMain.SelStart = 0
rtfMain.SetFocus
End Sub