How To Locate and Replace Special Characters in an XML Document with Visual Basic

Option Explicit

Public cn As New adodb.Connection
Public rs As New adodb.Recordset
Public myI As Integer
Public StrTmp As String
Public Errs1 As Errors
Public myFSO As New FileSystemObject
Public myTxtStream As TextStream
Public myfld As adodb.Field
Public domdoc As New MSXML.DOMDocument
Public domdoc As New MSXML2.DOMDocument 'For use with XML 2.6

					

Private Sub cmdOpenAdoFsoRs_Click()
Screen.MousePointer = vbHourglass

'Check to be sure the connection is not already opened:
If cn.State = 1 Then
    cn.Close
    Set cn = Nothing
End If

cn.Open "driver={SQL Server};Server=YourServer;uid=YourUID;pwd=YourPWD;database=Northwind"

'Check to be sure a Recordset is not already opened:
If rs.State = 1 Then
    rs.Close
    Set rs = Nothing
End If

With rs
    .CursorLocation = adUseClient
    .CursorType = adOpenKeyset
    .LockType = adLockOptimistic
    .CacheSize = 50
    .Source = "Select CustomerID, " & _
    "CompanyName, ContactName, Region from Customers"
    .ActiveConnection = cn
    .Open
End With

rs.MoveLast
rs.MoveFirst

txtFsoRecordCount.Text = rs.RecordCount

Screen.MousePointer = vbNormal

End Sub

Private Sub cmdExit_Click()
If cn.State = 1 Then
    cn.Close
    Set cn = Nothing
End If

If rs.State = 1 Then
    rs.Close
    Set rs = Nothing
End If

Unload Me

End Sub

Private Sub cmdSaveRSasXMLwithFso_Click()
Screen.MousePointer = vbHourglass

'If the file already exists, first Kill it
'and then create it.
'If it does not already exist, simply create it:

On Error GoTo mdkNoSeeEm
Const mdkNoSeeEm = 53 'File Not Found
Kill "Customers.xml"

'Note: Unicode data is stored as 2 Bytes per character. This will allow
'proper parsing of international language characters. However, either
'omitting or explicitly setting the last 'argument in the CreateTextFile 
'Method to False will create the file as Ascii. Subsequently, a '"An 
'Invalid Character Was Found in Text Content" error will occur if these 
'characters exist in 'the text. Therefore, you use Unicode (True). 

'Create a Text file using the FileSystemObject:

Set myTxtStream = myFSO.CreateTextFile(App.Path & "\Customers.xml", True, True)

'After searching for and replacing special characters with
'their respective entities (via the ReplaceEntXMLSpecChar Function),
'write the data to Text File to compile XML Document using the TextStream:

myTxtStream.WriteLine "<?xml version=""1.0"" standalone=""yes""?>"
myTxtStream.WriteLine "<Customers>"

rs.MoveFirst

    Do While Not rs.EOF
myTxtStream.WriteLine "<Customer>"
myTxtStream.WriteLine "<CustomerID>" & ReplaceEntXMLSpecChar(rs.Fields("CustomerID") & "", "&", "amp;") & "</CustomerID>"
myTxtStream.WriteLine "<CompanyName>" & ReplaceEntXMLSpecChar(rs.Fields("CompanyName") & "", "&", "amp;") & "</CompanyName>"
myTxtStream.WriteLine "<ContactName>" & ReplaceEntXMLSpecChar(rs.Fields("ContactName") & "", "&", "amp;") & "</ContactName>"
myTxtStream.WriteLine "<Region>" & ReplaceEntXMLSpecChar(rs.Fields("Region") & "", "&", "amp;") & "</Region>"
myTxtStream.WriteLine "</Customer>"
rs.MoveNext
Loop

rs.MoveFirst

myTxtStream.WriteLine "</Customers>"

myTxtStream.Close

Screen.MousePointer = vbNormal

Exit Sub

mdkNoSeeEm:
    If Err.Number = mdkNoSeeEm Then
        Resume Next
    End If
    
Screen.MousePointer = vbNormal

End Sub

'When this function is applied to each record in the recordset,
'simply provide the Source to perform the search on, the item
'to be Searched For and the item to Replace with:

Private Function ReplaceEntXMLSpecChar(ByVal strSource As String, ByVal strSearchFor As String, ByVal strReplace As String) _
    As String
    Dim lngPointer As Long, strNew As String
    lngPointer = InStr(strSource, strSearchFor)
    If lngPointer = 0 Then
        ReplaceEntXMLSpecChar = strSource
    Else
        strNew = Left$(strSource, lngPointer - 1) & strReplace & Mid(strSource, lngPointer + 1, Len(strSource))
        ReplaceEntXMLSpecChar = strNew
    End If
End Function

Private Sub cmdFsoXmltoTreeView_Click()
'Fill The TreeView with data from the XML Document:

With DOMdoc
    .async = False
    .Load App.Path & "\customers.xml"
End With

If DOMdoc.readyState = 4 Then
    xtvFSO.Nodes.Clear
    AddNode DOMdoc.documentElement
End If
End Sub
Private Sub AddNode(ByRef myNode As IXMLDOMNode, Optional ByRef TreeNode As Node)

       Dim tvcusterrNode As Node
       Dim tvcusterrNodeList As IXMLDOMNodeList
       Dim i As Long
                
       If TreeNode Is Nothing Then
           Set tvcusterrNode = xtvFSO.Nodes.Add
       Else
           Set tvcusterrNode = xtvFSO.Nodes.Add(TreeNode, tvwChild)
       End If
          
       tvcusterrNode.Expanded = True
       tvcusterrNode.Text = myNode.nodeName
          
       If tvcusterrNode.Text = "#text" Then
              tvcusterrNode.Text = myNode.nodeTypedValue
       Else
              tvcusterrNode.Text = "<" & tvcusterrNode.Text & ">"
  End If