QTP的对象解析vb脚本

如需转载，必须标注出处：http://blog.csdn.net/toella/article/details/7325839

解析文件ObjectDBTransfer.vbs，脚本如下：

===============================================================================

Option Explicit
Dim xmlDoc,myErr,strXML,rootNode,bobjDom,objRootlist,objnodes,element,rootOldNode
Set xmlDoc=CreateObject("Microsoft.XMLDOM")
xmlDoc.async=False
xmlDoc.load ".\obj.xml"
Dim ResXML,ResrootNode,ResrootG,RnewAttr
Set ResXML=CreateObject("Microsoft.XMLDOM")
Set ResrootNode=ResXML.createElement("qtpRep:ObjectRepository")
ResXML.appendChild ResrootNode
Set RnewAttr=ResXML.createAttribute("xmlns:qtpRep")
ResrootNode.setAttribute "xmlns:qtpRep","http://www.mercury.com/qtp/ObjectRepository"
If xmlDoc.parseError.errorCode<>0 Then
 Set myErr=xmlDoc.parseError
 MsgBox("XML Loads Failed."&myErr.reason)
Else
 Set rootNode=xmlDoc.documentElement
 Call rTravel(rootNode,ResrootNode,ResXML)
 ResXML.save ".\filterObj.xml"
End If

Sub rTravel(rNode,ResrNode,Rxml)
Dim blnTwo,intTestCase,iLen,i,child,childtext
Dim valueA,valueB,valueC
Dim newNode,newAttr,newAttr1
Dim ciIndex,cjIndex,ckIndex,ci,cj,ck
Dim childA,childB,childC,childT
valueA="qtpRep:Objects"
valueB="qtpRep:Object"
valueC="qtpRep:ChildObjects"
blnTwo=False
iLen=rNode.childNodes.length-1
If iLen>=0 Then
 For i=0 To iLen
  Set child=rNode.childNodes.item(i)
  childtext=child.nodeName
  strXML=strXML&child.nodeValue&Chr(13)
  Select Case childtext
  Case valueA,valueC
   Set newNode=Rxml.createElement(childtext)
   ResrNode.appendChild Rxml.createTextNode(vbCrLf)
   ResrNode.appendChild Rxml.createTextNode(Space(4))
   ResrNode.appendChild newNode
   ResrNode.appendChild Rxml.createTextNode(vbCrLf)
   ResrNode.appendChild Rxml.createTextNode(Space(4))
'   If child.hasChildNodes then
'   ciIndex=child.childNodes.length-1
'   If ciIndex>=0 Then
'   For ci=0 To ciIndex
'   Set child=child.childNodes.item(ci)
'   Call rTravel(child,newNode,Rxml)
'   Next
'   End If
'   End if
   If child.hasChildNodes Then
    Call rTravel(child,newNode,Rxml)
   End If
'   Set childA=child.nextSibling
'   If childA.nodeName <> "#text" Then
'   If childA.hasChildNodes Then
'   MsgBox childA.nodeName
'   Call rTravel(childA,newNode,Rxml)
'   End If
'   Set childA=childA.nextSibling
'   End if
        Case valueB
   Set newNode=Rxml.createElement(childtext)
   ResrNode.appendChild Rxml.createTextNode(vbCrLf)
   ResrNode.appendChild Rxml.createTextNode(Space(4))
   ResrNode.appendChild newNode
   Set newAttr=Rxml.createAttribute("Class")
   newNode.setAttribute "Class",child.getAttributeNode("Class").value
   Set newAttr1=Rxml.createAttribute("Name")
   newNode.setAttribute "Name",child.getAttributeNode("Name").value
   ResrNode.appendChild Rxml.createTextNode(vbCrLf)
   ResrNode.appendChild Rxml.createTextNode(Space(4))
   If child.hasChildNodes Then
    Call rTravel(child,newNode,Rxml)
   End If
  Case Else
   If child.hasChildNodes Then
    Call rTravel(child,newNode,Rxml)
   End If
  End Select
 Next
Else
 Exit Sub
' iLen=iLen+1
End If

End Sub

'获取同级下一个节点
'function get_nextsibling(n)
'{
'var x=n.nextSibling;
'while (x.nodeType!=1)
' {
' x=x.nextSibling;
' }
'return x;
'}

'获取同级上一个节点
'function get_previoussibling(n)
'{
'var x=n.previousSibling;
'while (x.nodeType!=1)
'  {
'  x=x.previousSibling;
'  }
'return x;
'}

 ===============================================

使用说明：

1、你录制好的对象库为*.tsr文件
2、将该对象库通过QTP另存为obj.xml文件，放置到ObjectDBTransfer.vbs同一目录下
3、运行解析代码ObjectDBTransfer.vbs
4、该目录下产生文件名为"filterObj.xml"