makexmlfromshapefiletable.txt

The script requires four fields, X, Y, label, and html. Currently these four fields are the only fi

Private Sub MakeXMLFromShapefileTable()
'vars
    Dim pMxDoc                      As IMxDocument
    Dim pMap                        As IMap
    Dim pFLayer                     As IFeatureLayer
    Dim pFClass                     As IFeatureClass
    Dim pFCur                       As IFeatureCursor
    Dim pTable                      As ITable
    Dim pRow                        As IRow
    Dim dblLat                      As Double
    Dim dblLng                      As Double
    Dim strHtml                     As String
    Dim strLabel                    As String
    Dim strFile                     As String
    Dim FSO                         As Scripting.FileSystemObject
    Dim fs                          As Object
    Dim fGen                        As Object
    
    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap
    Set pFLayer = pMxDoc.FocusMap.Layer(0)
    Set FSO = New Scripting.FileSystemObject
    Set fs = CreateObject("Scripting.FileSystemObject")
'set up
    If FSO.FileExists("C:/temp/Traps.xml") = True Then
        FSO.DeleteFile ("C:/temp/Traps.xml")
    End If
    strFile = "C:/temp/Traps.xml"
    Set fGen = fs.OpenTextFile(strFile, 8, True, 0)
'loop through the table and write lines
    Set pFClass = pFLayer.FeatureClass
    Set pTable = pFClass
    Set pFCur = pFClass.Search(Nothing, True)
    intFID = pTable.FindField("FID")
    Set pRow = pFCur.NextFeature
    fGen.WriteLine ("<Traps>")
    Do While Not pRow Is Nothing
        dblLat = pRow.value(pRow.Fields.FindField("Y"))
        dblLng = pRow.value(pRow.Fields.FindField("X"))
        strHtml = pRow.value(pRow.Fields.FindField("html"))
        strLabel = pRow.value(pRow.Fields.FindField("label"))
        fGen.WriteLine ("<Trap lng=" & Chr(34) & dblLng & Chr(34) & " lat=" & Chr(34) & dblLat & Chr(34) & " html=" & Chr(34) & strHtml & Chr(34) & " label=" & Chr(34) & strLabel & Chr(34) & "/>")
        Set pRow = pFCur.NextFeature
    Loop
    fGen.WriteLine ("</Traps>")
MsgBox "XML Created!"
End Sub