将QTP共享OR转换为关键字类型的DP对象库,并导出到Excel
Dim Repository
Set Repository = CreateObject("Mercury.ObjectRepositoryUtil.1")
Repository.Load "C:\Test.tsr"
'Set Repository = XMLUtil.CreateXMLFromFile("C:\Temp\TestOR.xml")
'This array will be used to store all the object definitions
Dim outArray
Redim outArray(0)
'Header row of he excel sheet
outArray(0) = Array("Keyword", "Type", "Parent", "Indentifier1", "Indentifier2", "Indentifier3", "Indentifier4", "Indentifier5", "Indentifier6")
'This function will recursively enumerate all the objects present in the OR
Call EnumerateObjectsIntoArray(Null, "", outArray)
'Save all the array details to a XLS
ExportArrayToXLS outArray,"C:\Test.xls"
Set Repository = Nothing
Function EnumerateObjectsIntoArray(Root, ByVal Parent, ByRef OutArray)
Dim TOCollection, TestObject, PropertiesCollection, PropertyObj, Msg
Dim sColumns
'Get the childrens'
Set TOCollection = Repository.GetChildren(Root)
For i = 0 To TOCollection.Count - 1
sColumns = Array("","","","","","","","","","")
'Get the Test Object
Set TestObject = TOCollection.Item(i)
'Get all TO properties for the test object
Set PropertiesCollection = TestObject.GetTOProperties()
'Get the object information
sColumns(0) = Repository.GetLogicalName(TestObject) 'Name
sColumns(1) = TestObject.GetTOProperty("micclass") 'Type
sColumns(2) = Parent 'Parent
'Populate the identification properties
For n = 0 To PropertiesCollection.Count - 1
Set PropertyObj = PropertiesCollection.Item(n)
sColumns(3 + n) = PropertyObj.Name & ":=" & PropertyObj.Value
Next
'Increase the Array size by 1 and add the new object
ReDim Preserve outArray(UBound(OutArray,1) + 1)
outArray(UBound(OutArray,1)) = sColumns
'Call the function recursively and pass the name of current object
EnumerateObjectsIntoArray TestObject, sColumns(0), OutArray
Next
End Function
'Funtion to export a 2-d array to excel file
Function ExportArrayToXLS(ByVal ValArray, ByVal FileName)
'Declare constants
Const xlEdgeLeft = 7
Const xlEdgeTop = 8
Const xlEdgeBottom = 9
Const xlEdgeRight = 10
Const xlInsideVertical = 11
Const xlInsideHorizontal = 12
Const xlThin = 2
Const xlAutomatic = -4105
Const xlContinuous = 1
Dim i, iCount
Dim xlApp, xlWorkbook, xlWorksheet
'Create the excel application object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Add a new workbook
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Worksheets.Item(1)
'Change the name
xlWorksheet.Name = "ExportedOR"
sLastColumn = GetColumnName(UBound(ValArray(0)) + 1)
iCount = UBound(ValArray) + 1
'Update sheet row by row
For i = 1 To iCount
xlWorksheet.Range("A"&i&":"&sLastColumn&i) = ValArray(i-1)
Next
'Yellow color and bold font for header
xlWorksheet.Range("A1:"&sLastColumn&"1").Interior.ColorIndex = 6
xlWorksheet.Range("A1:"&sLastColumn&"1").Font.Bold = True
'Add borders to all cells
With xlWorksheet.Range("A1:"&sLastColumn&(iCount))
For i = xlEdgeLeft To xlInsideHorizontal
.Borders(i).LineStyle = xlContinuous
.Borders(i).Weight = xlThin
Next
End With
'Autofit all columns
xlWorksheet.Columns.Autofit
'Save sheet and close excel
'DisplayAlerts needs to be false to disable the overwrite file message
xlApp.DisplayAlerts = False
xlWorkbook.SaveAs FileName
xlWorkbook.Close
xlApp.Quit
'Clean up
Set xlWorksheet = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing
End Function
Function GetColumnName(ByVal Index)
GetColumnName = Chr(Asc("A") + (Index - 1) Mod 26)
Index = (Index - 1) \ 26
If Index <> 0 Then GetColumnName = Chr(Asc("A") + (Index - 1) Mod 26) + GetColumnName
End Function
