Flag = IsFriday()
If Flag = True Then
Call ProjectInfo("xxxxx","xxx","xxx","xxx")
End If '获取QC上所有项目，循环统计
Function ProjectInfo(qcUrl,qcUsername,qcPassword,qcDomain)
Set Tdc = CreateObject("TDApiOle80.TDConnection.1")
If Not Tdc.Connected Then
Tdc.InitConnectionEx qcUrl
Tdc.Login qcUsername,qcPassword
Else
Tdc.Disconnect
Tdc.Logout
Tdc.ReleaseConnection
Tdc.Login qcUsername,qcPassword
End If
Message = ""
Msg = ""
For Each project In tdc.VisibleProjects(qcDomain)
Tdc.Disconnect
Tdc.Connect qcDomain,project
Set BugFac = tdc.BugFactory
Set BugList = BugFac.NewList("")
' MsgBox BugList.count
BugCount = 0
ReferCount = 0 '提交
RejectCount = 0 '拒绝
DeployCount = 0 ' 部署
ValidateCount = 0 '验证
ClosedCount = 0 '关闭
ReopenCount = 0 '未修复
For Each Bug In BugList
BugDate = CDate(Bug.Field("BG_DETECTION_DATE"))
CurrentDate = Date
LastDate = GetLastWeekDate()
If (BugDate <= CDate(CurrentDate) And BugDate >= CDate(LastDate)) Then
'缺陷总数
BugCount = BugCount + 1
'已提交总数
If Bug.Field("BG_USER_01") = "已提交" Then
ReferCount = ReferCount + 1
End If
'已驳回总数
If Bug.Field("BG_USER_01") = "已驳回" Then
RejectCount = RejectCount + 1
End If
'待部署总数
If Bug.Field("BG_USER_01") = "待部署" Then
DeployCount = DeployCount + 1
End If
'待验证总数
If Bug.Field("BG_USER_01") = "待验证" Then
ValidateCount = ValidateCount + 1
End If
'未修复总数
If Bug.Field("BG_USER_01") = "未修复" Then
ReopenCount = ReopenCount + 1
End If
'已关闭总数
If Bug.Field("BG_USER_01") = "已关闭" Then
ClosedCount = ClosedCount + 1
End If
End If
Next
Message = Message + "<p><table width=100 border=""1"" align=""left"">"& VbCrLf &_
"<th colspan=2>"&project&"</th>"& VbCrLf &_
"<tr><td width=60%>"&"已提交"&"</td><td width=40%>"&ReferCount&"</td></tr>"& VbCrLf &_
"<tr><td>"&"已驳回"&"</td><td>"&RejectCount&"</td></tr>"& VbCrLf &_
"<tr><td>"&"待部署"&"</td><td>"&DeployCount&"</td></tr>"& VbCrLf &_
"<tr><td>"&"待验证"&"</td><td>"&ValidateCount&"</td></tr>"& VbCrLf &_
"<tr><td>"&"未修复"&"</td><td>"&ReopenCount&"</td></tr>"& VbCrLf &_
"<tr><td>"&"已关闭"&"</td><td>"&ClosedCount&"</td></tr>"& VbCrLf &_
"</Table></p>"& VbCrLf
' MsgBox Message
Set BugList = Nothing
Set BugFac = Nothing
Next
Msg = "<html><head><title></title>" &VbCrLf &_
"<style. type='text/css'>"&VbCrLf &_
"td,form,select,input,p,table,.font {font-size: 12px;line-height: 20px}"&VbCrLf &_
"table"&VbCrLf &_
"{border-collapse: collapse}"&VbCrLf &_
"</style>"&VBCRLF &_
"</head><body>"&Message&"</body></html>"
Call SendMailMessage("xxx","xxx","xxx","xx",msg,"xxx")
Tdc.Disconnect
Tdc.Logout
Tdc.ReleaseConnection
Set Tdc = Nothing
End Function '邮件发送方法
Sub SendMailMessage(FromMail,MailPassword,ToMail,MailName,MailMessage,SmtpServer)
FromMailName=Split(FromMail , "@", -1, vbTextCompare)
MS_Space = "http://schemas.microsoft.com/cdo/configuration/"
Set Email = CreateObject("CDO.Message")
oEmail.From = FromMail '发送邮件地址
oEmail.To = ToMail '送达邮件地址
'处理中文乱码
Set BodyPart = oEmail.BodyPart
oBodyPart.Charset = "UTF-8"
oEmail.Subject = MailName '邮件标题
oEmail.HTMLBody = MailMessage '邮件正文
'配置邮件发送
With oEmail.Configuration.Fields
.Item(MS_Space&"sendusing") = 2 '发信端口
.Item(MS_Space&"smtpserver") = SmtpServer 'SMTP服务器地址
.Item(MS_Space&"smtpserverport") = 25 'SMTP服务器端口
.Item(MS_Space&"smtpauthenticate") = 1
.Item(MS_Space&"sendusername") = FromMailName(0) '邮件帐号
.Item(MS_Space&"sendpassword") = MailPassword
' .Item(MS_Space&"cdoSendlanguagecode")="UTF-8"
.Update
End With
'发送邮件
oEmail.Send
'释放对象
Set BodyPart = Nothing
Set Email = Nothing
End Sub '判断当前日期是否星期五
Function IsFriday()
CurrentDate = Date
Num = Weekday(CurrentDate,2)
If Num = 5 Then
Flag = True
Else
Flag = False
End If
IsFriday = Flag
End Function '获取当前日期前一周日期
Function GetLastWeekDate()
CurrentDate = Date
LastWeekDate = DateAdd("d",-7,CurrentDate)
GetLastWeekDate = LastWeekDate
End Function
|
