XML Pretty Print - Merapikan Format File XML

Private Sub PrettyPrint(Parent As IXMLDOMNode, Optional Level As Integer)
    Dim Node As IXMLDOMNode
    Dim Indent As IXMLDOMText

    If Not Parent.ParentNode Is Nothing And Parent.ChildNodes.Length > 0 Then
        For Each Node In Parent.ChildNodes
            Set Indent = Node.OwnerDocument.createTextNode(vbNewLine & String(Level, vbTab))

            If Node.NodeType = NODE_TEXT Then
                If Trim(Node.Text) = "" Then
                    Parent.RemoveChild Node
                End If
            ElseIf Node.PreviousSibling Is Nothing Then
                Parent.InsertBefore Indent, Node
            ElseIf Node.PreviousSibling.NodeType <> NODE_TEXT Then
                Parent.InsertBefore Indent, Node
            End If
        Next Node
    End If

    If Parent.ChildNodes.Length > 0 Then
        For Each Node In Parent.ChildNodes
            If Node.NodeType <> NODE_TEXT Then PrettyPrint Node, Level + 1
        Next Node
    End If
End Sub

READ MORE - XML Pretty Print - Merapikan Format File XML

XML Tidy - Untuk Merapikan File XML

Public Function PrettyPrintXML(XML As String) As String

    Dim Reader As New SAXXMLReader60
    Dim Writer As New MXXMLWriter60

    Writer.Indent = True
    Writer.standalone = False
    Writer.omitXMLDeclaration = False
    Writer.encoding = "utf-8"

    Set Reader.contentHandler = Writer
    Set Reader.dtdHandler = Writer
    Set Reader.errorHandler = Writer

    Call Reader.putProperty("http://xml.org/sax/properties/declaration-handler", _
    Writer)
    Call Reader.putProperty("http://xml.org/sax/properties/lexical-handler", _
    Writer)

    Call Reader.parse(XML)

    PrettyPrintXML = Writer.output

End Function

Public Function PrettyPrintDocument(Doc As DOMDocument60) As String
    PrettyPrintDocument = PrettyPrintXML(Doc.XML)
End Function

READ MORE - XML Tidy - Untuk Merapikan File XML

Encode Decode Base64 Menggunakan MSXML

Public Function Base64Enc(ByRef vxbData() As Byte) As String
    With CreateObject("MSXML.DOMDocument").CreateElement(" Base64 ")
        .DataType = "bin.base64"
        .NodeTypedValue = vxbData
        Base64Enc = .Text
    End With
End Function

Public Function Base64Dec(ByRef vsData As String) As Byte()
    With CreateObject("MSXML.DOMDocument").CreateElement("Base64")
        .DataType = "bin.base64"
        .Text = vsData
        Base64Dec = .NodeTypedValue
    End With
End Function

READ MORE - Encode Decode Base64 Menggunakan MSXML

Contoh Memparsing XML Attributes

Private Sub Command1_Click()

    Dim fso As Object
    Dim sDir As String
    Dim doc As Object
    Dim oFile As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    sDir = "C:\work"
    Set doc = CreateObject("Msxml2.DOMDocument")
    doc.async = False
    For Each oFile In fso.GetFolder(sDir).Files
        Debug.Print "looking at", oFile.Name
        Debug.Print "will load", oFile.Path
        If doc.Load(oFile.Path) Then
            Debug.Print "successfully loaded", oFile.Name
        End If
    Next
    Set ndlEventId = doc.documentElement.selectNodes("//*")
    For i = 0 To ndlEventId.length - 1
        Debug.Print ndlEventId(i).nodeName & " :: " & ndlEventId(i).Text
        If ndlEventId(i).Text = "" Then
            s = ndlEventId(i).nodeName
            Debug.Print s
            Set attrvalue = doc.getAttribute(s)
            Debug.Print attrvalue
        End If
    Nex
End Sub

READ MORE - Contoh Memparsing XML Attributes

Contoh Menggunakan tarts-with() Dalam Fungsi XPath

Private Sub Command1_Click()
    Dim doc As MSXML2.DOMDocument
    Dim nlist As MSXML2.IXMLDOMNodeList
    Dim node As MSXML2.IXMLDOMNode

    Set doc = New MSXML2.DOMDocument
    doc.setProperty "SelectionLanguage", "XPath"
    doc.Load "c:\books.xml"
    Set nlist = doc.selectNodes("//book/author/first-name[starts-with(.,'M')]")
    MsgBox "Matching Nodes : " & nlist.length

    For Each node In nlist
      Debug.Print node.nodeName & " : " & node.Text
    Next
End Sub

READ MORE - Contoh Menggunakan tarts-with() Dalam Fungsi XPath

Contoh Kode XML Query XPath

Option Explicit

Dim gCn As New ADODB.Connection

Const DBGUID_DEFAULT As String = "{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}"
Const DBGUID_SQL As String = "{C8B522D7-5CF3-11CE-ADE5-00AA0044773D}"
Const DBGUID_MSSQLXML As String = "{5D531CB2-E6Ed-11D2-B252-00C04F681B71}"
Const DBGUID_XPATH As String = "{ec2a4293-e898-11d2-b1b7-00c04f680c56}"

Private Sub cmdExitProgram_Click()
    Unload Me
    End
End Sub

Private Sub cmdTestIt_Click()

    Dim cmd As ADODB.Command
    Dim strm As ADODB.Stream

    On Error GoTo trap
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = gCn

    Set strm = New ADODB.Stream
    strm.Open
    cmd.Dialect = DBGUID_XPATH

    cmd.Properties("Mapping Schema") = App.Path & "\CustomerOrder.xdr"
    cmd.Properties("Output Stream") = strm

    txtXPath = Trim(txtXPath)
    If txtXPath = "" Then
        txtXPath = "Customers"
    End If

    cmd.CommandText = txtXPath
    cmd.Execute , , adExecuteStream
    strm.Position = 0
    txtResults = strm.ReadText
    txtResults = Replace(txtResults, "><", ">" & vbCrLf & "<")
    strm.Position = 0
    strm.Close

    GoTo cleanup

trap:

    MsgBox "Error (" & Err.Number & ") -- " & Err.Description

cleanup:
    Set strm = Nothing
    Set cmd = Nothing

    Exit Sub

End Sub

Private Sub Form_Load()

On Error GoTo trap
    Set gCn = New ADODB.Connection
    gCn.ConnectionString = "PROVIDER=SQLOLEDB;Data Source=.;Initial Catalog=Northwind;uid=sa;pwd="
    gCn.Open
    Exit Sub
trap:
    MsgBox "Failed to connect to database.  Program Shutting down."
    Unload Me
    End
End Sub

READ MORE - Contoh Kode XML Query XPath

VB6 Code - XML Yang Mengandung Binary Data

Option Explicit

Dim oDoc As DOMDocument
Dim DOCINPATH As String
Dim XMLOUTPATH As String
Dim DOCOUTPATH As String

Private Sub cmdCreateXML_Click()

    Dim oEle As IXMLDOMElement
    Dim oRoot As IXMLDOMElement
    Dim oNode As IXMLDOMNode

    DOCINPATH = App.Path & "\DocInput.doc"
    XMLOUTPATH = App.Path & "\XmlOuput.xml"

    Call ReleaseObjects

    Set oDoc = New DOMDocument
    oDoc.resolveExternals = True

    Set oNode = oDoc.createProcessingInstruction("xml", "version='1.0'")
    Set oNode = oDoc.insertBefore(oNode, oDoc.childNodes.Item(0))

    Set oRoot = oDoc.createElement("Root")
    Set oDoc.documentElement = oRoot
    oRoot.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"

    Set oNode = oDoc.createElement("Document")
    oNode.Text = "Demo"
    oRoot.appendChild oNode

    Set oNode = oDoc.createElement("CreateDate")
    oRoot.appendChild oNode
    Set oEle = oNode

    oEle.dataType = "date"
    oEle.nodeTypedValue = Now

    Set oNode = oDoc.createElement("bgColor")
    oRoot.appendChild oNode
    Set oEle = oNode

    oEle.dataType = "bin.hex"
    oEle.Text = &HFFCCCC

    Set oNode = oDoc.createElement("Data")
    oRoot.appendChild oNode
    Set oEle = oNode

    oEle.dataType = "bin.base64"
    oEle.nodeTypedValue = ReadBinData(DOCINPATH)
    oDoc.Save XMLOUTPATH

    MsgBox XMLOUTPATH & " is created for you."

End Sub

Function ReadBinData(ByVal strFileName As String) As Variant
    Dim lLen As Long
    Dim iFile As Integer
    Dim arrBytes() As Byte
    Dim lCount As Long
    Dim strOut As String

    iFile = FreeFile()
    Open strFileName For Binary Access Read As iFile
    lLen = FileLen(strFileName)
    ReDim arrBytes(lLen - 1)
    Get iFile, , arrBytes
    Close iFile

    ReadBinData = arrBytes
End Function

Private Sub WriteBinData(ByVal strFileName As String)
    Dim iFile As Integer
    Dim arrBuffer() As Byte
    Dim oNode As IXMLDOMNode

    If Not (oDoc Is Nothing) Then
        Set oNode = oDoc.documentElement.selectSingleNode("/Root/Data")
        arrBuffer = oNode.nodeTypedValue
        iFile = FreeFile()
        Open strFileName For Binary Access Write As iFile
        Put iFile, , arrBuffer
        Close iFile
    End If

End Sub

Private Sub cmdGetBinary_Click()
    DOCOUTPATH = App.Path & "\DocOutput.doc"
    Set oDoc = New DOMDocument
    If oDoc.Load(XMLOUTPATH) = True Then
        WriteBinData DOCOUTPATH

        MsgBox DOCOUTPATH & " is created for you."
    Else
        MsgBox oDoc.parseError.reason
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ReleaseObjects
End Sub

Private Sub ReleaseObjects()
    Set oDoc = Nothing
End Sub

READ MORE - VB6 Code - XML Yang Mengandung Binary Data

Menggunakan XMLHTTP dan MSXML

Private Sub Command1_Click()
    Dim soapReq As String
    Dim objSOAPXMLDoc As New MSXML2.DOMDocument30
    Dim objXMLHTTP As New MSXML2.XMLHTTP30

    Dim btArr() As Byte

    Dim backSlashPos As Integer
    Dim fileNameNoPath As String

    soapReq = " " & _
    " " & _
    "   " & _
    "  " & _
    "    " & _
    "    " & _
    "  " & _
    "   " & _
    " "

    backSlashPos = InStrRev(txtFileName.Text, "\")
    If backSlashPos > 0 Then
        fileNameNoPath = Mid(txtFileName.Text, backSlashPos + 1)
    Else
        fileNameNoPath = txtFileName.Text
    End If

    objSOAPXMLDoc.loadXML soapReq

    objSOAPXMLDoc.setProperty "SelectionNamespaces", _
    "xmlns:pxml='http://samples.perfectxml.com/BinaryData'"

    objSOAPXMLDoc.selectSingleNode("//pxml:fileName").nodeTypedValue = _
    fileNameNoPath

    objSOAPXMLDoc.selectSingleNode("//pxml:imageData").dataType = _
    "bin.base64"

    Open txtFileName.Text For Binary Access Read As #1
    ReDim btArr(LOF(1))
    Get #1, , btArr()
    Close #1

    objSOAPXMLDoc.selectSingleNode("//pxml:imageData").nodeTypedValue = btArr
    MsgBox objSOAPXMLDoc.xml

    objXMLHTTP.open "POST", "http://localhost/EmpImages/EmpImages.asmx", False

    objXMLHTTP.setRequestHeader "Content-Type", "text/xml; charset=utf-8"

    objXMLHTTP.setRequestHeader "SOAPAction", _
    "http://samples.perfectxml.com/BinaryData/SaveImage"

    objXMLHTTP.setRequestHeader "Content-Length", Len(objSOAPXMLDoc.xml)

    objXMLHTTP.send objSOAPXMLDoc.xml

    MsgBox objXMLHTTP.Status & ": " & objXMLHTTP.statusText
    MsgBox objXMLHTTP.responseText

    Set objXMLHTTP = Nothing
    Set objSOAPXMLDoc = Nothing

End Sub

READ MORE - Menggunakan XMLHTTP dan MSXML

XML VB6 - Mencari Node Tertentu Menggunakan XPath

Public Function SearchForNodes(ByVal strXML As String, ByVal strTag As String, ByVal strSearchText As String) As DOMDocument
    'Will Search an XML String for a Tag-value pair and return
    'the entire node containing that pair in the form
    'of a DOM Document: 'REQUIRES REFERENCE TO MSXML
    'EXAMPLE: 'Dim objXMLDoc As New DOMDocument
    'Dim objXMLFound As DOMDocument 'Dim strXML As String
    'Load XML from file 'If objXMLDoc.Load("C:\My Documents\MyXMLFile.xml") Then
    'strXML = objXMLDoc.xml 'Search for a tag that looks like this in the xml:
    '583 'Set objXMLFound = SearchForNodes(strXML, "User_ID", "583")
    'Display the Node that was found 'Debug.Print objXMLFound.xml
    'End If
    Dim lngIterator As Long
    Dim strResults As String
    Dim objXMLSearchDocument As DOMDocument
    Dim objXMLSearchElements As IXMLDOMSelection
    Dim objXMLSearchElement As IXMLDOMElement
    Dim strXPath As String
    strResults = ""
    Set objXMLSearchDocument = New DOMDocument
    objXMLSearchDocument.async = False
    objXMLSearchDocument.setProperty "SelectionLanguage", "XPath"
    Call objXMLSearchDocument.loadXML(strXML)
    Set objXMLSearchElements = objXMLSearchDocument.getElementsByTagName(strTag)
    If objXMLSearchElements.length > 0 Then
        Set objXMLSearchElement = objXMLSearchElements.Item(0)
        Do Until Len(objXMLSearchElement.parentNode.baseName) = 0
            strXPath = "/" + objXMLSearchElement.parentNode.baseName + strXPath
            Set objXMLSearchElement = objXMLSearchElement.parentNode
        Loop
        Set objXMLSearchElement = Nothing
        strXPath = strXPath + "[" + strTag + " = '" + strSearchText + "']"
    End If
    Set objXMLSearchElements = Nothing
    If Len(strXPath) > 0 Then
        Set objXMLSearchElements = objXMLSearchDocument.selectNodes(strXPath)

        If objXMLSearchElements.length > 0 Then
            For lngIterator = 0 To (objXMLSearchElements.length - 1)
                strResults = strResults + objXMLSearchElements.Item(lngIterator).xml
            Next lngIterator
        End If
        Set objXMLSearchElements = Nothing
    End If
    Set objXMLSearchDocument = Nothing
    strResults = strResults + ""
    Set objXMLSearchDocument = New DOMDocument
    objXMLSearchDocument.async = False
    Call objXMLSearchDocument.loadXML(strResults)
    Set SearchForNodes = objXMLSearchDocument
    Set objXMLSearchDocument = Nothing
End Function

READ MORE - XML VB6 - Mencari Node Tertentu Menggunakan XPath

Parse XML Menggunakan Visual Basic 6.0

Sub ParseXmlDocument()
   Dim doc As New MSXML2.DOMDocument
   Dim success As Boolean

   success = doc.Load(App.Path & "\test.xml")
   If success = False Then
      MsgBox doc.parseError.reason
   Else
      Dim nodeList As MSXML2.IXMLDOMNodeList

      Set nodeList = doc.selectNodes("/Report/Categories/Category")

      If Not nodeList Is Nothing Then
         Dim node As MSXML2.IXMLDOMNode
         Dim name As String
         Dim value As String

         For Each node In nodeList
            ' Could also do node.attributes.getNamedItem("name").text
            name = node.selectSingleNode("@name").Text
            value = node.selectSingleNode("@value").Text
         Next node
      End If
   End If
End Sub

READ MORE - Parse XML Menggunakan Visual Basic 6.0

Tidy XML Menggunakan XSL Transform - VB6 Source Code

Private Function TidyXML(sXML As String) As String
    Dim oXSLT As DOMDocument
    Dim XSL_FILE As String
    Dim sResult As String
    Const DoubleQuotes = """"
    Dim strText As String
    Dim objDom As DOMDocument
 
    Set objDom = New DOMDocument
    objDom.loadXML sXML
 
    Set oXSLT = New DOMDocument
    XSL_FILE = "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" & DoubleQuotes & "?>" & vbCrLf & "<xsl:stylesheet version=" & DoubleQuotes & "1.0" & DoubleQuotes & " xmlns:xsl=" & DoubleQuotes & "http://www.w3.org/1999/XSL/Transform" & DoubleQuotes & ">" & vbCrLf & "     <xsl:output method=" & DoubleQuotes & "xml" & DoubleQuotes & " version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" & DoubleQuotes & " indent=" & DoubleQuotes & "yes" & DoubleQuotes & "/>" & vbCrLf & "     <xsl:template match=" & DoubleQuotes & "@* | node()" & DoubleQuotes & ">" & vbCrLf & "          <xsl:copy>" & vbCrLf & "               <xsl:apply-templates select=" & DoubleQuotes & "@* | node()" & DoubleQuotes & " />" & vbCrLf & "          </xsl:copy>" & vbCrLf & "     </xsl:template>" & vbCrLf & "</xsl:stylesheet>"
    objDom.async = False
    oXSLT.async = False
    oXSLT.loadXML XSL_FILE
    If oXSLT.parseError.errorCode = 0 Then
        If oXSLT.readyState = 4 Then
            sResult = objDom.transformNode(oXSLT.documentElement)
            sResult = Replace$(sResult, "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-16" & DoubleQuotes & "?>", vbNullString, , , vbTextCompare)
            objDom.loadXML sResult
        End If
    Else
        Debug.Print Err.Description = oXSLT.parseError.reason & vbCrLf & "Line: " & oXSLT.parseError.Line & vbCrLf & "XML: " & oXSLT.parseError.srcText
        Err.Clear
    End If
 
    strText = objDom.xml
 
    TidyXML = strText
End Function

READ MORE - Tidy XML Menggunakan XSL Transform - VB6 Source Code

Merger 2 File XML Menggunakan Visual Basic 6.0

Private Sub AddPostNew(XMLSource As String, XMLDestination As String) 
 
    Dim strText As String 
    Dim strPost As String 
 
    Dim domFree As FreeThreadedDOMDocument60 
    Dim domApt As DOMDocument60 
    Dim node As IXMLDOMNode 
    Dim clone As IXMLDOMNode 
    Dim msg As String 
 
    msg = "" 
    Set domFree = New FreeThreadedDOMDocument60 
    Set domApt = New DOMDocument60 
 
    domApt.async = False 
    If False = domApt.loadXML(XMLDestination) Then 
        MsgBox "can't load doc1.xml" 
        Exit Sub 
    End If 
 
    domFree.async = False 
    If False = domFree.loadXML(XMLSource) Then 
        MsgBox "can't load doc2.xml" 
        Exit Sub 
    End If 
 
    Dim nodeId As IXMLDOMAttribute 
    Set node = domFree.documentElement 
 
    Set clone = domApt.importNode(node, True) 
 
    domApt.documentElement.appendChild clone 
    domApt.documentElement.appendChild domApt.createTextNode(vbNewLine) 
 
    Set node = Nothing 
    Set clone = Nothing 
 
    domApt.save strPathXML 
 
End Sub 

READ MORE - Merger 2 File XML Menggunakan Visual Basic 6.0

VB6 Code - Mengevaluasi XPath dengan XPath Checker

Berikut adalah kode VB6 yang digunakan untuk mengevaluasi XPath yang digunakan untuk melakukan query terhadap file XML:

Option Explicit 
 
Private Sub cmdEvaluate_Click() 
 
On Error GoTo ErrHandler 
     
    txtErrorXpath.Text = "" 
     
    Dim doc As MSXML2.DOMDocument60 
    Dim nlist As MSXML2.IXMLDOMNodeList 
    Dim node As MSXML2.IXMLDOMNode 
     
    Set doc = New MSXML2.DOMDocument60 
     
    doc.setProperty "SelectionLanguage", "XPath" 
    doc.loadXML txtXMLSource.Text 
     
    Set nlist = doc.selectNodes(txtXPath.Text) 
    lblMathcing.Caption = "Matching Nodes : " & nlist.length 
 
    lstMatchingFound.Clear 
 
    For Each node In nlist 
      lstMatchingFound.AddItem node.nodeName & " : " & node.Text 
    Next 
     
    Exit Sub 
     
ErrHandler: 
     
    lstMatchingFound.Clear 
    txtErrorXpath.Text = "Error: " & Err.Description 
     
End Sub 

READ MORE - VB6 Code - Mengevaluasi XPath dengan XPath Checker

XML Pretty Print - Merapikan Format File XML

Private Sub PrettyPrint(Parent As IXMLDOMNode, Optional Level As Integer)
Dim Node As IXMLDOMNode
Dim Indent As IXMLDOMText

If Not Parent.ParentNode Is Nothing And Parent.ChildNodes.Length > 0 Then
For Each Node In Parent.ChildNodes
Set Indent = Node.OwnerDocument.createTextNode(vbNewLine & String(Level, vbTab))

If Node.NodeType = NODE_TEXT Then
If Trim(Node.Text) = "" Then
Parent.RemoveChild Node
End If
ElseIf Node.PreviousSibling Is Nothing Then
Parent.InsertBefore Indent, Node
ElseIf Node.PreviousSibling.NodeType <> NODE_TEXT Then
Parent.InsertBefore Indent, Node
End If
Next Node
End If

If Parent.ChildNodes.Length > 0 Then
For Each Node In Parent.ChildNodes
If Node.NodeType <> NODE_TEXT Then PrettyPrint Node, Level + 1
Next Node
End If
End Sub

READ MORE - XML Pretty Print - Merapikan Format File XML