exporting xml from access 2000 query

R

rzaxl

Hi
Im trying to convert an access 2000 query to xml with this vba code

Attribute value VB_Name = "XML"
Option Compare Database
Option Explicit

Sub QFN(MyQName As String, WithFormats As Byte)
Dim MyDb As Database, TDefLoop As QueryDef, MySet As Recordset, MyFormat()
As String
Dim FNames() As String, n As Integer, MyF As Field, Tt As String, NumF As
Integer
Set MyDb = CurrentDb()

For Each TDefLoop In MyDb.QueryDefs
If TDefLoop.Name = MyQName Then
Debug.Print "List of fields in '" & UCase(TDefLoop.Name) & "'"
NumF = TDefLoop.Fields.Count - 1
ReDim FNames(NumF)
ReDim MyFormat(NumF)
Debug.Print Format(NumF + 1, "0") & " fields, " & Format(Date, "dd/mm/yy")

For n = 0 To NumF
Set MyF = TDefLoop.Fields(n)

Select Case MyF.Type
Case 2
Tt = "Byte"
MyFormat(n) = "0"
Case 3
MyFormat(n) = "#,##0;(#,##0)"
Tt = "Integer"
Case 4
Tt = "Long"
MyFormat(n) = "#,##0;(#,##0)"
Case 5
Tt = "Currency"
MyFormat(n) = "£#,##0;(£#,##0)"
Case 6
Tt = "Single"
MyFormat(n) = "#,##0;(#,##0)"
Case 7
Tt = "Double"
MyFormat(n) = "#,##0;(#,##0)"
Case 8
Tt = "Date"
MyFormat(n) = "dd/mm/yy"
Case 10
Tt = "Text"
MyFormat(n) = "T"
Case 12
Tt = "Memo"
MyFormat(n) = "T"

Case Else
Tt = "Not known"
MyFormat(n) = "T"
End Select

If InStr(1, MyF.Name, "WTE") > 0 Then
MyFormat(n) = "#,##0.00;(#,##0.00)"
End If

Debug.Print n + 1 & ". " & MyF.Name & " (" & Tt & ") > " & MyFormat(n)
FNames(n) = MyF.Name ', MyF.Size, MyF.SourceTable

Next n
End If
Next TDefLoop

Set MySet = MyDb.OpenRecordset(MyQName, dbOpenDynaset)
Open "c:\MyXMLtest.xml" For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" &
Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<" & FillSpaces(MyQName) & ">"

MySet.MoveFirst
Do Until MySet.EOF
Print #1, "<mydata>"
For n = 0 To NumF
If MyFormat(n) = "T" Or WithFormats = 0 Then
Tt = RemoveAmpersands(MySet.Fields(n).Value) ' The & character is not
allowed in XML
Else
Tt = Format(MySet.Fields(n).Value, MyFormat(n))
End If

Print #1, "<" & FillSpaces(FNames(n)) & ">" & Tt & "</" &
FillSpaces(FNames(n)) & ">"
Next n
Print #1, "</mydata>"
MySet.MoveNext
Loop

Print #1, "</" & FillSpaces(MyQName) & ">"
Close #1
MySet.Close
MyDb.Close
End Sub

Function FillSpaces(AnyStr As String) As String
' replace spaces with underscores
Dim MyPos As Integer

MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "_"
MyPos = InStr(1, AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "+"
MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function


To invoke this code I have a button, that when clicked should start the
process]]
Private Sub Command0_Click()
QFN "cimtest", 1
End Sub

I have googles everything about exporting xml from access 2000 qurey, but to
know avail, when ever I click the button, it throws up a compile time error
due to :

Attribute value VB_Name = "XML"


Could someone please help me!!!!!!!!!!!!!!!!1
RzaXL
 
A

Alex Dybenko

Hi,
try to remove this line:
Attribute value VB_Name = "XML"


--
Best regards,
___________
Alex Dybenko (MVP)
http://accessblog.net
http://www.PointLtd.com


rzaxl said:
Hi
Im trying to convert an access 2000 query to xml with this vba code

Attribute value VB_Name = "XML"
Option Compare Database
Option Explicit

Sub QFN(MyQName As String, WithFormats As Byte)
Dim MyDb As Database, TDefLoop As QueryDef, MySet As Recordset, MyFormat()
As String
Dim FNames() As String, n As Integer, MyF As Field, Tt As String, NumF As
Integer
Set MyDb = CurrentDb()

For Each TDefLoop In MyDb.QueryDefs
If TDefLoop.Name = MyQName Then
Debug.Print "List of fields in '" & UCase(TDefLoop.Name) & "'"
NumF = TDefLoop.Fields.Count - 1
ReDim FNames(NumF)
ReDim MyFormat(NumF)
Debug.Print Format(NumF + 1, "0") & " fields, " & Format(Date,
"dd/mm/yy")

For n = 0 To NumF
Set MyF = TDefLoop.Fields(n)

Select Case MyF.Type
Case 2
Tt = "Byte"
MyFormat(n) = "0"
Case 3
MyFormat(n) = "#,##0;(#,##0)"
Tt = "Integer"
Case 4
Tt = "Long"
MyFormat(n) = "#,##0;(#,##0)"
Case 5
Tt = "Currency"
MyFormat(n) = "£#,##0;(£#,##0)"
Case 6
Tt = "Single"
MyFormat(n) = "#,##0;(#,##0)"
Case 7
Tt = "Double"
MyFormat(n) = "#,##0;(#,##0)"
Case 8
Tt = "Date"
MyFormat(n) = "dd/mm/yy"
Case 10
Tt = "Text"
MyFormat(n) = "T"
Case 12
Tt = "Memo"
MyFormat(n) = "T"

Case Else
Tt = "Not known"
MyFormat(n) = "T"
End Select

If InStr(1, MyF.Name, "WTE") > 0 Then
MyFormat(n) = "#,##0.00;(#,##0.00)"
End If

Debug.Print n + 1 & ". " & MyF.Name & " (" & Tt & ") > " & MyFormat(n)
FNames(n) = MyF.Name ', MyF.Size, MyF.SourceTable

Next n
End If
Next TDefLoop

Set MySet = MyDb.OpenRecordset(MyQName, dbOpenDynaset)
Open "c:\MyXMLtest.xml" For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" &
Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<" & FillSpaces(MyQName) & ">"

MySet.MoveFirst
Do Until MySet.EOF
Print #1, "<mydata>"
For n = 0 To NumF
If MyFormat(n) = "T" Or WithFormats = 0 Then
Tt = RemoveAmpersands(MySet.Fields(n).Value) ' The & character is not
allowed in XML
Else
Tt = Format(MySet.Fields(n).Value, MyFormat(n))
End If

Print #1, "<" & FillSpaces(FNames(n)) & ">" & Tt & "</" &
FillSpaces(FNames(n)) & ">"
Next n
Print #1, "</mydata>"
MySet.MoveNext
Loop

Print #1, "</" & FillSpaces(MyQName) & ">"
Close #1
MySet.Close
MyDb.Close
End Sub

Function FillSpaces(AnyStr As String) As String
' replace spaces with underscores
Dim MyPos As Integer

MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "_"
MyPos = InStr(1, AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "+"
MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function


To invoke this code I have a button, that when clicked should start the
process]]
Private Sub Command0_Click()
QFN "cimtest", 1
End Sub

I have googles everything about exporting xml from access 2000 qurey, but
to
know avail, when ever I click the button, it throws up a compile time
error
due to :

Attribute value VB_Name = "XML"


Could someone please help me!!!!!!!!!!!!!!!!1
RzaXL
Click to expand...
 
R

rzaxl

point taken alex, that works, thanks; but there is just one problem I have
which is this line : Set MyF = TDefLoop.Fields(n)

Now MyF is of field type & TDefLoop is of Qurey Def, but as I'm transfering
the field element within TDefLoop to MyF. I cannot understand why it is
throwing up a type miss-match error 13 error. Could you please advice
--
RzaXL


Alex Dybenko said:
Hi,
try to remove this line:
Attribute value VB_Name = "XML"


--
Best regards,
___________
Alex Dybenko (MVP)
http://accessblog.net
http://www.PointLtd.com


rzaxl said:
Hi
Im trying to convert an access 2000 query to xml with this vba code

Attribute value VB_Name = "XML"
Option Compare Database
Option Explicit

Sub QFN(MyQName As String, WithFormats As Byte)
Dim MyDb As Database, TDefLoop As QueryDef, MySet As Recordset, MyFormat()
As String
Dim FNames() As String, n As Integer, MyF As Field, Tt As String, NumF As
Integer
Set MyDb = CurrentDb()

For Each TDefLoop In MyDb.QueryDefs
If TDefLoop.Name = MyQName Then
Debug.Print "List of fields in '" & UCase(TDefLoop.Name) & "'"
NumF = TDefLoop.Fields.Count - 1
ReDim FNames(NumF)
ReDim MyFormat(NumF)
Debug.Print Format(NumF + 1, "0") & " fields, " & Format(Date,
"dd/mm/yy")

For n = 0 To NumF
Set MyF = TDefLoop.Fields(n)

Select Case MyF.Type
Case 2
Tt = "Byte"
MyFormat(n) = "0"
Case 3
MyFormat(n) = "#,##0;(#,##0)"
Tt = "Integer"
Case 4
Tt = "Long"
MyFormat(n) = "#,##0;(#,##0)"
Case 5
Tt = "Currency"
MyFormat(n) = "£#,##0;(£#,##0)"
Case 6
Tt = "Single"
MyFormat(n) = "#,##0;(#,##0)"
Case 7
Tt = "Double"
MyFormat(n) = "#,##0;(#,##0)"
Case 8
Tt = "Date"
MyFormat(n) = "dd/mm/yy"
Case 10
Tt = "Text"
MyFormat(n) = "T"
Case 12
Tt = "Memo"
MyFormat(n) = "T"

Case Else
Tt = "Not known"
MyFormat(n) = "T"
End Select

If InStr(1, MyF.Name, "WTE") > 0 Then
MyFormat(n) = "#,##0.00;(#,##0.00)"
End If

Debug.Print n + 1 & ". " & MyF.Name & " (" & Tt & ") > " & MyFormat(n)
FNames(n) = MyF.Name ', MyF.Size, MyF.SourceTable

Next n
End If
Next TDefLoop

Set MySet = MyDb.OpenRecordset(MyQName, dbOpenDynaset)
Open "c:\MyXMLtest.xml" For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" &
Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<" & FillSpaces(MyQName) & ">"

MySet.MoveFirst
Do Until MySet.EOF
Print #1, "<mydata>"
For n = 0 To NumF
If MyFormat(n) = "T" Or WithFormats = 0 Then
Tt = RemoveAmpersands(MySet.Fields(n).Value) ' The & character is not
allowed in XML
Else
Tt = Format(MySet.Fields(n).Value, MyFormat(n))
End If

Print #1, "<" & FillSpaces(FNames(n)) & ">" & Tt & "</" &
FillSpaces(FNames(n)) & ">"
Next n
Print #1, "</mydata>"
MySet.MoveNext
Loop

Print #1, "</" & FillSpaces(MyQName) & ">"
Close #1
MySet.Close
MyDb.Close
End Sub

Function FillSpaces(AnyStr As String) As String
' replace spaces with underscores
Dim MyPos As Integer

MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "_"
MyPos = InStr(1, AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "+"
MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function


To invoke this code I have a button, that when clicked should start the
process]]
Private Sub Command0_Click()
QFN "cimtest", 1
End Sub

I have googles everything about exporting xml from access 2000 qurey, but
to
know avail, when ever I click the button, it throws up a compile time
error
due to :

Attribute value VB_Name = "XML"


Could someone please help me!!!!!!!!!!!!!!!!1
RzaXL
Click to expand...

.
Click to expand...
 
A

Alex Dybenko

Hi,
try to declare it as DAO.Field:
MyF As DAO.Field

--
Best regards,
___________
Alex Dybenko (MVP)
http://accessblog.net
http://www.PointLtd.com


rzaxl said:
point taken alex, that works, thanks; but there is just one problem I have
which is this line : Set MyF = TDefLoop.Fields(n)

Now MyF is of field type & TDefLoop is of Qurey Def, but as I'm
transfering
the field element within TDefLoop to MyF. I cannot understand why it is
throwing up a type miss-match error 13 error. Could you please advice
--
RzaXL


Alex Dybenko said:
Hi,
try to remove this line:
Attribute value VB_Name = "XML"


--
Best regards,
___________
Alex Dybenko (MVP)
http://accessblog.net
http://www.PointLtd.com


rzaxl said:
Hi
Im trying to convert an access 2000 query to xml with this vba code

Attribute value VB_Name = "XML"
Option Compare Database
Option Explicit

Sub QFN(MyQName As String, WithFormats As Byte)
Dim MyDb As Database, TDefLoop As QueryDef, MySet As Recordset,
MyFormat()
As String
Dim FNames() As String, n As Integer, MyF As Field, Tt As String, NumF
As
Integer
Set MyDb = CurrentDb()

For Each TDefLoop In MyDb.QueryDefs
If TDefLoop.Name = MyQName Then
Debug.Print "List of fields in '" & UCase(TDefLoop.Name) & "'"
NumF = TDefLoop.Fields.Count - 1
ReDim FNames(NumF)
ReDim MyFormat(NumF)
Debug.Print Format(NumF + 1, "0") & " fields, " & Format(Date,
"dd/mm/yy")

For n = 0 To NumF
Set MyF = TDefLoop.Fields(n)

Select Case MyF.Type
Case 2
Tt = "Byte"
MyFormat(n) = "0"
Case 3
MyFormat(n) = "#,##0;(#,##0)"
Tt = "Integer"
Case 4
Tt = "Long"
MyFormat(n) = "#,##0;(#,##0)"
Case 5
Tt = "Currency"
MyFormat(n) = "£#,##0;(£#,##0)"
Case 6
Tt = "Single"
MyFormat(n) = "#,##0;(#,##0)"
Case 7
Tt = "Double"
MyFormat(n) = "#,##0;(#,##0)"
Case 8
Tt = "Date"
MyFormat(n) = "dd/mm/yy"
Case 10
Tt = "Text"
MyFormat(n) = "T"
Case 12
Tt = "Memo"
MyFormat(n) = "T"

Case Else
Tt = "Not known"
MyFormat(n) = "T"
End Select

If InStr(1, MyF.Name, "WTE") > 0 Then
MyFormat(n) = "#,##0.00;(#,##0.00)"
End If

Debug.Print n + 1 & ". " & MyF.Name & " (" & Tt & ") > " &
MyFormat(n)
FNames(n) = MyF.Name ', MyF.Size, MyF.SourceTable

Next n
End If
Next TDefLoop

Set MySet = MyDb.OpenRecordset(MyQName, dbOpenDynaset)
Open "c:\MyXMLtest.xml" For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" &
Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<" & FillSpaces(MyQName) & ">"

MySet.MoveFirst
Do Until MySet.EOF
Print #1, "<mydata>"
For n = 0 To NumF
If MyFormat(n) = "T" Or WithFormats = 0 Then
Tt = RemoveAmpersands(MySet.Fields(n).Value) ' The & character is
not
allowed in XML
Else
Tt = Format(MySet.Fields(n).Value, MyFormat(n))
End If

Print #1, "<" & FillSpaces(FNames(n)) & ">" & Tt & "</" &
FillSpaces(FNames(n)) & ">"
Next n
Print #1, "</mydata>"
MySet.MoveNext
Loop

Print #1, "</" & FillSpaces(MyQName) & ">"
Close #1
MySet.Close
MyDb.Close
End Sub

Function FillSpaces(AnyStr As String) As String
' replace spaces with underscores
Dim MyPos As Integer

MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "_"
MyPos = InStr(1, AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "+"
MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function


To invoke this code I have a button, that when clicked should start the
process]]
Private Sub Command0_Click()
QFN "cimtest", 1
End Sub

I have googles everything about exporting xml from access 2000 qurey,
but
to
know avail, when ever I click the button, it throws up a compile time
error
due to :

Attribute value VB_Name = "XML"


Could someone please help me!!!!!!!!!!!!!!!!1
RzaXL
Click to expand...

.
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

How to refer to programmatically Dynamice Range names 1
Code too large Extracting Txt Srtings 1
Excel Populate workbook A from Data in workbook B based off criteria in Workbook C 0
random number generation 1
Combine Two Different Worksheet_Change codes 9
UDF Function Not working 5
call function module from query - having much trouble 8
RunTime Error when Exporting Query 1

Top