使用脚本轻松导出本周纪录
使用脚本轻松导出本周纪录
因为CQ中没有关于本周纪录查询的const，如TODAY，TOMORROW，YESTODAY等，也因此给很多人带来了不少麻烦。
既然不能在客户端中直接建立这种查询（有人提过在客户端中通过使用SQL来实现，但是这种SQL可能很复杂，并不是每个人都能掌握的），所以本人就想到了使用外部脚本来实现。
思想：通过运行一个.vbs脚本，来查询本周纪录，并导出到Excel中。
实现：以下是实现这一思想的脚本，把它save成一个.vbs文件，然后把其中的session.Logon部分根据自己的实际情况来做适当的更改，保存后，任何时候一运行，就能把本周（一般是星期一到当前系统时间）纪录保存到一个excel文件中，非常方便。
' --------------------------------------------------------
' Script Name: Exprot_Weekly_Defects.vbs
' Author: yunshan
' Create Date: 2007-1-28
'---------------------------------------------------------
' Declare the global constant
Public Const SUCCESS = 1
Public Const AD_BOOL_OP_AND = 1
Public Const AD_COMP_OP_EQ = 1
Dim curDate
Dim curWeek
Dim interval
Dim strDate
' Get the current date and compute the strDate
curWeek = DatePart("w", Now)
interval = (curWeek + 6) Mod 7
If interval = 0 Then
interval = 7
End If
interval = interval - 1
strDate = DateAdd("d", -interval, Date)
' The start date of this week is from monday, time initial is 00:00:00
strDate = strDate & " 00:00:00"
Dim session
Dim resultset
' Login to the destination database
Set session = CreateObject("CLEARQUEST.SESSION")
session.UserLogon "admin", "", "cdi", AD_PRIVATE_SESSION, "cdi"
' Build Query On defect
Set resultset = session.BuildSQLQuery("select T1.id,T1.headline,T7.name,T1.priority, " &_
"T2.login_name,T1.submit_date from Defect T1,statedef T7,users T2 where T1.state = T7.id " &_
"and T1.owner = T2.dbid and Submit_Date between"&_
" #"& strDate &"# and #"& curDate &"#")
'resultset.EnableRecordCount
resultset.Execute
Dim xlsApp
Dim newBook
Dim newSheet
' Create Excel App and set property for the new file
Set xlsApp = CreateObject("Excel.Application")
set newBook = xlsApp.Workbooks.Add
with newBook
.Title = "All this weeks defect"
.Subject = "ClearQuest"
.Activate
End With
' work with sheet1
Set newSheet = newBook.Worksheets("Sheet1")
newSheet.Visible = True
newSheet.Name = "Weekly Defects"
' set column title
newSheet.Range("A1:F1").Value = Array("ID","Headline","State","Priority","Owner","Submit Date")
newSheet.Range("A1:F1").Font.Bold = True
' set values for destination cells
Dim i
i = 2
Do While resultset.MoveNext = SUCCESS
newSheet.Cells(i,1).Value = resultset.GetColumnValue(1)
newSheet.Cells(i,2).Value = resultset.GetColumnValue(2)
newSheet.Cells(i,3).Value = resultset.GetColumnValue(3)
newSheet.Cells(i,4).Value = resultset.GetColumnValue(4)
newSheet.Cells(i,5).Value = resultset.GetColumnValue(5)
newSheet.Cells(i,6).Value = resultset.GetColumnValue(6)
i = i + 1
Loop
' Save changes to the excel
newBook.SaveAs("C:\WeeklyDefects.xls")
' release the objects
Set newSheet = Nothing
newBook.Close
Set newBook = Nothing
xlsApp.Quit
Set xlsApp = Nothing
Set resultset = Nothing
Set session = Nothing
MsgBox "Finish exporting records!"
' 大家可以在这个脚本的基础上作适当的改动，以扩展它的功能。
'==================================================================
' 对以上脚本的升级
' Author: yunshan
' Description: 改动部分用黑体标出
'==================================================================
Public Const SUCCESS = 1
Public Const AD_BOOL_OP_AND = 1
Public Const AD_COMP_OP_EQ = 1
Public Const AD_COMP_OP_BETWEEN = 9
Dim curWeek
Dim interval
Dim strDate
' Get the current date and compute the strDate
curWeek = DatePart("w", Now)
interval = (curWeek + 6) Mod 7
If interval = 0 Then
interval = 7
End If
interval = interval - 1
strDate = DateAdd("d", -interval, Date)
strDate = strDate & " 00:00:00"
Dim session
Dim qryObj
Dim filterObj
Dim resultset
Dim dateRange
ReDim dateRange(1)
dateRange(0) = strDate
' <yunshan> 修正了一个小错误，把dateRange(1) = Now 改成了dateRange(1) = Cstr(Now)，否则运行会出错。
dateRange(1) = Cstr(Now)
' Login to the destination database
Set session = CreateObject("CLEARQUEST.SESSION")
session.UserLogon "admin", "", "productDB", AD_PRIVATE_SESSION, "masterDB"
' Build Query On defect
Set qryObj = session.BuildQuery("defect")
qryObj.BuildField("id")
qryObj.BuildField("headline")
qryObj.BuildField("State")
qryObj.BuildField("priority")
qryObj.BuildField("owner")
qryObj.BuildField("Submit_Date")
Set node = qryObj.BuildFilterOperator(AD_BOOL_OP_AND)
node.BuildFilter "Submit_Date",AD_COMP_OP_BETWEEN, dateRange
Set resultset = session.BuildResultSet(qryObj)
' resultset.EnableRecordCount
resultset.Execute
Dim xlsApp
Dim newBook
Dim newSheet
' Create Excel App and set property for the new file
Set xlsApp = CreateObject("Excel.Application")
set newBook = xlsApp.Workbooks.Add
with newBook
.Title = "All this weeks defect"
.Subject = "ClearQuest"
.Activate
End With
' work with sheet1
Set newSheet = newBook.Worksheets("Sheet1")
newSheet.Visible = True
newSheet.Name = "Weekly Defects"
' set column title
With newSheet.Range("A1:F1")
.Value = Array("ID","Headline","State","Priority","Owner","Submit Date")
.Font.Bold = True
.Font.Color = vbWhite
.Interior.ColorIndex = 1
End With
' set values for destination cells
Dim i
i = 2
Do While resultset.MoveNext = SUCCESS
newSheet.Cells(i,1).Value = resultset.GetColumnValue(1)
newSheet.Cells(i,2).Value = resultset.GetColumnValue(2)
newSheet.Cells(i,3).Value = resultset.GetColumnValue(3)
newSheet.Cells(i,4).Value = resultset.GetColumnValue(4)
newSheet.Cells(i,5).Value = resultset.GetColumnValue(5)
newSheet.Cells(i,6).Value = resultset.GetColumnValue(6)
i = i + 1
Loop
newSheet.Columns("A:F").AutoFit
newBook.SaveAs("C:\WeeklyDefects.xls")
newBook.Close
Set newBook = Nothing
xlsApp.Quit
Set xlsApp = Nothing
Set resultset = Nothing
Set session = Nothing
[ 本帖最后由 yunshan 于 2007-10-24 18:48 编辑 ]
