Showing posts with label XML-VB6. Show all posts
Showing posts with label XML-VB6. Show all posts

Sunday, June 17, 2012

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

Thursday, June 14, 2012

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

Saturday, June 9, 2012

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

Thursday, June 7, 2012

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

Saturday, June 2, 2012

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