Download defects from QC to Excel using QC OTA

Dim tdc
Set tdc = CreateObject("TDApiOle80.TDConnection")

Dim sUserName, sPassword
sUserName = "" '<-- br="" change="" me.="">sPassword = "" '<-- br="" change="" me.="">

Dim sDomain, sProject
sDomain = ""   '<-- br="" change="" me.="">sProject = "" '<-- change="" me.="" p="">
tdc.InitConnectionEx "http://qc..com/qcbin" '<-- br="" change="" url="">tdc.Login sUserName, sPassword
tdc.Connect sDomain, sProject

If (tdc.LoggedIn <> True) Then
    MsgBox "QC User Authentication Failed"
    'WScript.Quit
End If

Fn_Defects_To_Excel()

'========================================
 'To download defects from QC to excel sheet
'=========================================
Sub Fn_Defects_To_Excel()
Set BugFact = tdc.BugFactory

'If want to search defects with filter criteria, use below
'Set BugFilter = BugFact.Filter
'BugFilter.Filter("BG_STATUS") = "New"
'BugFilter.Order("BG_PRIORITY") = 1
'Set BugList = BugFilter.NewList("")

Set BugList = BugFact.NewList("")
'msgbox BugList.count
ExcelPath = ".xls"
'Set Excel = FnCreateExcel(ExcelPath)
Set Excel = CreateObject("Excel.Application") 'Open Excel
Excel.WorkBooks.Add() 'Add a new workbook
'Get the first worksheet.
Set Sheet = Excel.ActiveSheet
'Set Sheet = Excel.ActiveWorkbook.Worksheets(1)
Excel.DisplayAlerts  = False
'Set Sheet = Excel.workbooks.open(ExcelPath).Worksheets(1)

Sheet.Cells(1, 1) = "Bug ID"
Sheet.Cells(1, 2) = "Summary"
Sheet.Cells(1, 3) = "Description"
Excel.Columns(3).ColumnWidth = 60
Sheet.Cells(1, 4) = "Priority"
Sheet.Cells(1, 5) = "Status"
Sheet.Cells(1, 6) = "Detected By"
Sheet.Cells(1, 7) = "Responsibility"

Row = 2
For Each Bug in BugList
Sheet.Cells(Row, 1) = Bug.Field("BG_BUG_ID")
Sheet.Cells(Row, 2) = Bug.Field("BG_SUMMARY")
Description = FnFormatHTML(Bug.Field("BG_DESCRIPTION"))
Sheet.Cells(Row, 3) = Trim(Description)
'Sheet.Cells(Row+1, 3) = Bug.Field("BG_DESCRIPTION")
Sheet.Cells(Row, 4) = Bug.Field("BG_PRIORITY")
Sheet.Cells(Row, 5) = Bug.Field("BG_STATUS")
Sheet.Cells(Row, 6) = Bug.Field("BG_DETECTED_BY")
Sheet.Cells(Row, 7) = Bug.Field("BG_RESPONSIBLE")
Row = Row + 1
Next

Excel.ActiveSheet.UsedRange.EntireColumn.Autofit()
'Excel.workbooks.Save
Excel.ActiveWorkbook.SaveAs ExcelPath
Excel.workbooks.Close
Set Sheet = Nothing
Set Excel = Nothing
MsgBox "Done!"
End Sub

'===========================================
'Formats an HTML text to normal String
'==========================================
Function FnFormatHTML(strHTML)
    'Strips the HTML tags from strHTML
    Dim objRegExp, strOutput
    Set objRegExp = New Regexp
    objRegExp.IgnoreCase = True
    objRegExp.Global = True
    objRegExp.Pattern = "<(.|\n)+?>"
    'Replace all line breaks with VB line breaks
    strOutput = Replace(strHTML, "

", vbLf)
    strOutput = Replace (strOutput ,"
",vbLf)
    'Replace all HTML tag matches with the empty string
    strOutput = objRegExp.Replace(strOutput, "")
    'Replace all <, >, and " with <, >, and "
    strOutput = Replace(strOutput, "<", "<")
    strOutput = Replace(strOutput, ">", ">")
    strOutput = Replace(strOutput, """, Chr(34))
    strOutput= Replace( strOutput,"",Chr(8))
    strOutput = Replace(strOutput,"",Chr(8))
    strOutput = Replace(strOutput," ","")
    strOutput= Replace(strOutput,"
-",chr(13)& "-")
    strOutput = Replace (strOutput ,"
" ,"")
    strOutput = Replace (strOutput,"" ,"")
    'Replaces double blank lines to blank, but cant replace one single blank line
    strOutput = Replace (strOutput,vbLf&vbLf,"")
    strOutput = Replace (strOutput,chr(13),"")
    Set objRegExp = Nothing
    FnFormatHTML = strOutput    'Return the value of strOutput
End Function


'Note: I have listed few fields from the defect tab of QC, here are some fields from QC defect tab which you may need -
'BG_BUG_ID, BG_STATUS, BG_RESPONSIBLE, BG_PROJECT
'BG_SUMMARY, BG_DESCRIPTION, BG_SEVERITY, BG_SUBJECT
'BG_PRIORITY, BG_DETECTED_BY, BG_DETECTION_DATE, BG_CLOSING_DATE