QTP-OTA-导出BUG到EXCEL

上一篇 / 下一篇  2013-11-12 14:49:03 / 个人分类:QTP

最近研究QTP QC OTA写的VBS脚本
Call createBug()
Function createBug()

Dim TDConnection          
Dim htmlred
Dim Reporter
Set TDConnection = CreateObject("TDApiOle80.TDConnection")     
TDConnection.InitConnectionEx ""        
TDConnection.Login "", ""         
TDConnection.Connect "", ""       
If TDConnection.Connected Then      
'MsgBox("Connected to " + chr (13) + "Server " + TDConnection.ServerName+ chr (13) +"Project " + TDConnection.ProjectName )       
Else  MsgBox("Not Connected")
End if
TDConnection.IgnoreHtmlFormat=true
Set BugFactory = TDConnection.BugFactory     
Set fieldList = BugFactory.Fields
Set bugList = BugFactory.NewList("")

    Set Excel = CreateObject("Excel.Application")
     Excel.WorkBooks.Add
     Set Sheet = Excel.ActiveSheet
    Row = 1
        Sheet.Cells(Row, 1).Value = "BUG编号"
        Sheet.Cells(Row, 2).Value = "测试轮次"
        Sheet.Cells(Row, 3).Value = "更新时间"
        Sheet.Cells(Row, 4).Value = "记录时间"
        Sheet.Cells(Row, 5).Value = "可否复现"
        Sheet.Cells(Row, 6).Value = "BUG发现人"
        Sheet.Cells(Row, 15).Value = "附件地址"
     
   Row = 2
   For Each Bug In BugList
       Set attachFact = Bug.Attachments
    Set attachList = attachFact.NewList("")
If  attachList.count<>0 Then
Set attachObj = attachList.Item(1)

attachObj.Load True, "D:\Buglist\downloads"
Sheet.Cells(Row, 15).Value = attachObj.FileName
Sheet.Cells(Row, 15).Select
Sheet.Hyperlinks.Add Sheet.Cells(Row, 15), attachObj.FileName

else  Sheet.Cells(Row, 15).Value = "无附件"
End If
        Sheet.Cells(Row, 1).Value = Bug.id
        Sheet.Cells(Row, 2).Value = Bug.field("BG_user_01")
        Sheet.Cells(Row, 3).Value = Bug.field("BG_DETECTION_DATE")
        Sheet.Cells(Row, 4).Value = Bug.field("BG_user_07")
        Sheet.Cells(Row, 5).Value = Bug.field("BG_REPRODUCIBLE")
        Sheet.Cells(Row, 6).Value = Bug.field("BG_DETECTED_BY")
        Row = Row + 1
    Next

    Excel.ActiveWorkbook.SaveAs ("D:\Buglist\QualityCenter_DEFECTS.xls")
    Excel.Quit

    Set Excel = Nothing
    Set BugList = Nothing
Set Bug=nothing
Set TDConnection=nothing
End Function

TAG: QC QTP OTA

 

评分:0

我来说两句

Open Toolbar