这是以前指导过我的一个专家给我的代码,发出来给大家分享一下。作用和用法请查看代码里的注释。 '****************************************************************************************************************************************** '名称:GetAttachmentFromQC '说明:从QC服务器上的指定对象(Test、TestSet或者Defect)中找到指定名称的附件,下载到指定目录 '输入: ' TestObject - QC上的对象:Test、TestSet或Defect ' FileName - 下载目标文件名(附件) ' DstFolder - 下载目标文件夹 '返回: ' Bool类型,True代表取附件成功,False代表取附件失败 '示例:GetAttachmentOnQC QCUtil.CurrentTest, "data_file_attached.xls", "d:/temp" '设计人员:LYH '设计时间:08/10/23 '****************************************************************************************************************************************** Public Function GetAttachmentOnQC(TestObject, FileName, DstFolder) On Error Resume Next '初始化函数返回值 GetAttachmentOnQC = False '为DstFolder变量添加路径斜杠"/" If Right(DstFolder, 1) <> "/" Then DstFolder = DstFolder & "/" End If '取得AttachmentList对象,即TestObject的所有附件 Set AttachmentFactory = TestObject.Attachments Set AttachmentList = AttachmentFactory.NewList("SELECT * FROM CROS_REF") '先删除本地的文件. Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(DstFolder & Filename) then fso.DeleteFile DstFolder & Filename '删除文件 End if Set fso = Nothing '遍历TestObject对象的所有附件,找到名称为FileName的附件。附件 For Each Attachment in AttachmentList If InStr(1,Attachment.Name, FileName, 1) >= 1 Then Set AttachmentStorage = Attachment.AttachmentStorage AttachmentStorage.ClientPath=DstFolder AttachmentStorage.Load Attachment.Name,True '下载后重命名,去掉QC附件前缀。类似Test_#_Filename RenameFile DstFolder & Attachment.Name, DstFolder & Filename GetAttachmentOnQC = True Exit Function End If Next '错误情况处理 If Err.Number <> 0 Then Err.Clear GetAttachmentOnQC = False On Error GoTo 0 End If End Function '****************************************************************************************************************************************** '名称:AddAttachmentOnQC '说明:向QC服务器上的指定对象(Test、TestSet或者Defect)中添加附件 '输入: ' TestObject - QC上的对象:Test、TestSet或Defect ' FileName - 上传目标文件名(完全路径文件名,Full Path Name) '返回: ' Bool类型,True代表上传附件成功,False代表上传附件失败 '示例:AddAttachmentOnQC QCUtil.CurrentTest, "d:/temp/data_file_attached.xls" '设计人员:LYH '设计时间:08/10/23 '****************************************************************************************************************************************** Public Function AddAttachmentOnQC(TestObject, FileName) On Error Resume Next '初始化函数返回值 AddAttachmentOnQC = False '通过AddItem(Null)方法取得Attachment对象 Set AttachmentFactory = TestObject.Attachments Set Attachment = AttachmentFactory.AddItem(Null) '上传文件并更新 Attachment.FileName = FileName Attachment.Type = 1 Attachment.Post Attachment.Refresh AddAttachmentOnQC = True '错误情况处理 If Err.Number <> 0 Then Err.Clear GetAttachmentOnQC = False On Error GoTo 0 End If End Function '****************************************************************************************************************************************** '名称:ReplaceAttachmentOnQC '说明:替换QC服务器上指定对象(Test、TestSet或者Defect)的附件 '输入: ' TestObject - QC上的对象:Test、TestSet或Defect ' OldFileName - 待删除文件名 ' NewFileName - 待上传文件名(完全路径文件名,Full Path Name) '返回: ' Bool类型,True代表替换附件成功,False代表替换附件失败 '示例:ReplaceAttachmentOnQC QCUtil.CurrentTest, "data_file_attached.xls", "d:/temp/data_file_attached.xls" '设计人员:LYH '设计时间:08/10/23 '****************************************************************************************************************************************** Public Function ReplaceAttachmentOnQC(TestObject, OldFileName, NewFileName) On Error Resume Next '初始化函数返回值 ReplaceAttachmentOnQC = False '用Filter取得TestObject中符合FileName条件的附件 Set AttachmentFactory = TestObject.Attachments Set AttachmentFilter = AttachmentFactory.Filter '由于QC中保存的附件名称前都添加了如Test_#_的前缀 '需要对OldFileName进行处理,使Filter中使用的条件包含* OldFileName = Trim(OldFileName) If InStr(1, OldFileName, "*") = 1 Then AttachmentFilter.Filter("CR_REFERENCE") = OldFileName Else AttachmentFilter.Filter("CR_REFERENCE") = "*" & OldFileName End If '从经过搜索的附件List中删除附件 Set AttachmentList = AttachmentFactory.NewList(AttachmentFilter.Text) '如果找到一个或一个以上附件,取第一个附件删除并继续上传新文件 If AttachmentList.Count > 0 Then Set Attachment = AttachmentList.Item(1) AttachmentFactory.RemoveItem(Attachment.ID) '上传更新的附件 ReplaceAttachmentOnQC = AddAttachmentOnQC(TestObject, NewFileName) Else '如果没有找到附件,返回False。不继续上传新文件 ReplaceAttachmentOnQC = False End If '错误情况处理 If Err.Number <> 0 Then Err.Clear ReplaceAttachmentOnQC = False On Error GoTo 0 End If End Function