这部分代码是个人整理的个人使用QTP11+QC11所用到的框架，可移植性比较的好。
本部分代码归本人所用，未经本人允许，不可私自转载或用于商业用途。
所有框架代码如下：（持续更新中）
'******************************************************************************************* '功能:新建一个excel文件 '参数：需要保存的路径 '返回值：无 '作者：judd '******************************************************************************************* Function createExcel(filepath) On error resume next Dim excelapp Set excelapp=createobject("excel.application") set works=excelapp.Workbooks.Add works.SaveAs filepath works.Close Set excelapp=nothing Set works=nothing End Function '******************************************************************************************* '功能：打开excel并将数据values写入到excel中 '参数：filename表示需要写入数据的excel文件名，sheetname表示需要写入的excel的sheet名称，x代表excel代表单元格中的行，y代表单元格中的列，values代表需要写入单元格中的数据 '返回值：无 '作者：judd '******************************************************************************************* Function writeExcelDatas(filename,sheetindex,x,y,values) On error resume next Dim excelapp,fso testpath=getFilePath(filename) '获取需要写入的文件的路径 Set excelapp=CreateObject("Excel.Application") Set fso=CreateObject("scripting.filesystemobject") If fso.FileExists(testpath) Then '如果存在excel文件 excelapp.Visible=False Set xlswork=excelapp.Workbooks.Open(testpath) Set xlssheet=xlswork.Sheets(sheetindex) xlssheet.cells(x,y)=values xlswork.Save xlswork.Close Set excelapp=Nothing Else ' Exit function createExcel testpath reporter.ReportEvent micFail,"打开EXCEL文件","打开EXCEL文件失败，可能不存在该EXCEL文件！" End If End Function 'openAndWriteExcel "d:\maybe.xlsx",1,1,"abcziptestdddddddddddddddd" '******************************************************************************************* '功能：获取excel中指定的单元格中的数据 '参数：testpath表示需要写入数据的excel的路径，sheetname表示需要写入的excel的sheet名称，x代表excel代表单元格中的行，y代表单元格中的列 '返回值：获取你所需指定的单元格的值 '作者：judd '******************************************************************************************* Function readExcelDatas(filename,sheetindex,x,y) On error resume next Dim testpath testpath=getFilePath(filename) Set excelapp=CreateObject("Excel.Application") excelapp.Visible=false Set xlswork=excelapp.Workbooks.Open(testpath) Set xlssheet=xlswork.Sheets(sheetindex) values=xlssheet.cells(x,y) xlswork.Save xlswork.Close Set excelapp=Nothing readExcelDatas=values ' MsgBox "successbox" End Function 'MsgBox(getCellDatas("d:\maybe.xlsx",1,1)) '******************************************************************************************* '功能：获取excel文件的路径 '参数：path代表excel文件名 '返回值：获取excel文件的绝对路径 '作者： '******************************************************************************************* 'Function findPath(path) ' findPath=pathfinder.Locate(path) 'End Function '字符串截取特殊字符重新生成所需新的字符串 '******************************************************************************************* '功能：时间字符串格式转换 '参数：str代表时间字符串，formatdata代表需要截取的字符 '返回值：获取你所需指定的单元格的值 '作者：judd '******************************************************************************************* Function joinString(teststring,formatdata) converstr=Split(teststring,formatdata,-1,1) mystring=join(converstr,"") joinString=mystring End function '时间格式化操作函数 '******************************************************************************************* '功能：将vb的时间设置成固定的格式后 '参数：str代表时间字符串，formatdata代表需要截取的方式， '返回值：获取你所需指定的单元格的值 '作者：judd '******************************************************************************************* Function FormateDateTime(sendTime,Para) select case Para Rem 时间格式为：YYYYMMDDHHmmss case "1" sendTime = year(sendTime) & right( "00" & month(sendTime),2) & right( "00" & day(sendTime),2) & right( "00" & hour(sendTime),2) & right( "00" & minute(sendTime),2) & right( "00" & second(sendTime),2) Rem 时间格式为：YYYYMMDD case "2" sendTime = year(sendTime) & right( "00" & month(sendTime),2) & right( "00" & day(sendTime),2) Rem 时间格式为：YYYY-MM-DD case "3" sendTime = year(sendTime)&"-"&right("00"&month(sendTime),2)&"-"&right( "00"&day(sendTime),2) Rem 时间格式为：YYYY年MM月DD日 case "4" sendTime = year(sendTime) & "年 "& right( "00" & month(sendTime),2) & "月 "& right( "00" & day(sendTime),2)& "日" Rem 时间格式为：HH:mm:ss case "5" sendTime = right( "00"&hour(sendTime),2)&":"&right( "00"&minute(sendTime),2)&":"&right( "00"&second(sendTime),2) end select FormateDateTime = SendTime end Function '******************************************************************************************* '功能：发送邮件通知执行步骤 '参数：sentto表示需要发送的人，subject邮件的主题，body邮件需要发送的内容，attachment表示邮件的附件的路径 '返回值：无 '作者： '******************************************************************************************* Function SendMail(SendTo, Subject, Body, Attachment) Set ol=CreateObject("Outlook.Application") Set Mail=ol.CreateItem(0) Mail.to=SendTo Mail.Subject=Subject Mail.Body=Body If (Attachment <> "") Then Mail.Attachments.Add(Attachment) End If Mail.Send ol.Quit Set Mail = Nothing Set ol = Nothing End Function '******************************************************************************************* '功能：打印QTP的报告 '参数：teststep表示在QTP的报告中报告的步骤，expectvalue表示预期的测试执行结果，actualvalue表示实际的测试执行结果 '返回值; '作者： '******************************************************************************************* Function reportResult(teststep,expectvalue, actualvalue) 'expectvalue="exp_"&actualvalue finaltime=FormateDateTime(now(),"5") timestamp=mid(finaltime,4,2)+mid(finaltime,7,2) resultpath=environment.Value("RunImgs") resultlog=environment.Value("") 'listpath=resultpath&"\"&teststep&"---"×tamp&".png" imgpath=resultpath&"\"&teststep&"截图--"×tamp&".png" finalexpect=trim(expectvalue) finalactual=trim(actualvalue) '打印当前运行的状态。。 desktop.CaptureBitmap imgpath 'Reporter.ReportEvent micDone,"当前测试内容【"&teststep&"】,列表如下:","测试执行开始!!!",imgpath If finalexpect=finalactual Then 'desktop.CaptureBitmap imgpath Reporter.ReportEvent micPass,"当前的测试步骤为-【"&teststep&"】-执行成功！","当前的测试用例结果:"&",预期的测试结果为【"&finalexpect&"】,实际的测试结果为【"&finalactual&"】,与预期结果相同"&vbcrlf&"测试执行通过---PASS",imgpath else ' desktop.CaptureBitmap imgpath Reporter.ReportEvent micFail,"当前的测试步骤为-【"&teststep&"】-执行失败！","当前的测试用例结果:"&",预期的测试结果为【"&finalexpect&"】,实际的测试结果为【"&finalactual&"】,与结果不相同"&vbcrlf&"测试执行失败---FAILED",imgpath ' SendMail "charilyhu@gmail.com","测试执行步骤","执行步骤"&teststep,"" End If End Function '******************************************************************************************* '功能:在指定的已有的excel中插入一个sheet，最大支持45列（注意） '参数：filename表示excel的名称，oldsheetname表示需要excel文件中的第一个sheet的名称,templatefilename表示需要导入excel中的sheet的模板excel文件名称，支持模糊匹配 'templatefsheetname表示导入excel中的sheet的模板excel文件的sheet名称 '返回值： '******************************************************************************************* Function InsertNewSheet(filename,oldsheetname,templatefilename,templatesheetindex) On error resume next Dim workbook 'As Excel.workbook Dim worksheet 'As Excel.worksheet excelpath=getFilePath(filename) '如果指定的工作薄不存在，将在当前激活状态的工作表中添加工作表 'print excelpath Set ExcelApp=CreateObject("excel.application") Set xlwork=ExcelApp.Workbooks.Open(excelpath) Set workbook = ExcelApp.ActiveWorkbook sheetCount = workbook.Sheets.Count '获取工作薄中工作表的数量 Set tname=ExcelApp.Worksheets.Item(1) '得到第一个sheet名称 ' Debug.Write tname.name If (tname.name=oldsheetname) Then Set worksheet=workbook.Sheets.Add(, workbook.Sheets(sheetCount)) '添加工作表 ' Set worksheet = workbook.Sheets(sheetCount + 1) '初始化worksheet为新添加的工作表对象 ' = '初始化worksheet为新添加的工作表对象 '设置新添加的工作表名称 temppath=getFilePath(templatefilename) ' rownum=getRowRange(temppath,templatesheetindex) 'excel中的可用的行数,此处的调用会弹出excel对象重用的问题，所有不考虑使用这种方式 Set tempwork=ExcelApp.Workbooks.Open(temppath) rownum=ExcelApp.Worksheets(templatesheetindex).usedrange.rows.count getvalue=ExcelApp.Worksheets(templatesheetindex).usedrange.range("A1:AT"&rownum).value '得到可用区域的所有的表格的内容数组 For testrow=1 to rownum For valuecol=1 to 45 worksheet.cells(testrow,valuecol)=getvalue(testrow,valuecol) Next Next If oldsheetname <> "" Then worksheet.Name = oldsheetName&sheetCount InsertNewWorksheet = worksheet.Name End If Else reportProgress "文件sheet名称不存在，出现错误",2 End if ' ExcelApp.c ExcelApp.DisplayAlerts=false ExcelApp.SaveWorkspace ExcelApp.Save workbook.Close Set ExcelApp=Nothing End Function '******************************************************************************************* ' '功能：通过QTP的自身的环境变量进行确认相关的需要的路径 '参数：需要查询的文件的路径的文件名称 '返回值：返回查询文件的绝对路径 '******************************************************************************************* Function getFilePath(filename) On error resume next Set tfso=createobject("scripting.filesystemobject") testfiles=environment.Value("RunLogs") datapath=environment.Value("TestPath") tempFilePath datapath,filename '引入的下面的文件的遍历操作 set openfile=tfso.OpenTextFile(testfiles&"\FilePaths.txt") getFilePath=trim(openfile.ReadLine) '读取临时的log文件中的第一行的路径名称 openfile.Close Set openfile=nothing Set fso=nothing End Function '******************************************************************************************* ' '功能：遍历环境变量中预设的数据值路径，然后过滤找到指定的文件名，并存放在text文件中 '参数：datapath表示查找文件的路径，filename表示需要查找的文件名称 '返回值：无 '******************************************************************************************* Function tempFilePath(datapath,filename) On error resume next Set fso=createobject("scripting.filesystemobject") If fso.FolderExists(datapath) Then Set firstsub=fso.GetFolder(datapath) For each testfolder in firstsub.SubFolders strpath=datapath&"\"&testfolder.name tempFilePath strpath,filename Next For each testfile in firstsub.Files ' print testfile.name If instr(1,testfile.name,filename,1)<>0 Then logpath=environment.Value("RunLogs") 'If not fso.FileExists(logpath&"\FilePaths.txt") Then set logfile=fso.CreateTextFile(logpath&"\FilePaths.txt",true) logfile.WriteLine testfile.path else 'ReportProgress(Text, Title, TimeOut) 'ReportProgress "在指定的路径下没有找到你需要的文件" End If Next else 'ReportProgress(Text, Title, TimeOut) reportProgress "enviroment文件中的测试路径找不到，请确认你的environment文件正确配置或者加载到QTP中，使用loadQTPXML方法进行加载XML文件到QTP中！",2 End If logfile.Close Set logfile=nothing Set firstsub=nothing Set fso=nothing End Function 'Function: LoadDictionary 'Website: http://KnowledgeInbox.com 'Author: Tarun Lalwani 'Description: Load Dictionary object from a XML file 'Parameters: '@oDic: The Dictionary object in which the values need to be loaded '@FileName: The XMLfile path from where the dictionary needs to be loaded 'Return value: 'The oDic dictionary object Function LoadDictionary(oDic, FileName) 'Exit if the file doesn't exist If Not CreateObject("Scripting.FileSystemObject").FileExists(FileName) Then Exit Function Dim allKeys, sKey allKeys = oDic.Keys 'Load the XMLfile Set oXML = XMLutil.CreateXMLFromFile (FileName) Set oRoot = oXML.GetRootElement 'Load all XML variables Set allElements = oRoot.ChildElementsByPath("//Variable") Dim oElement 'Enumerate and populate each dictionary key For i = 1 to allElements.Count Set oElement = allElements.Item(i) sKey = oElement.ChildElementsByPath("Name").Item(1).CDATASections.Item(1) sValue = oElement.ChildElementsByPath("Value").Item(1).CDATASections.Item(1) oDic(sKey) = sValue Next End Function 'Function: LoadDictionary 'Website: http://KnowledgeInbox.com 'Author: Tarun Lalwani 'Description: Save dictionary object to a XML file 'Parameters: '@oDic: The Dictionary object for which the values need to be exported as XML '@FileName: The XMLfile path where the dictionary needs to be saved 'Return value: 'The oDic dictionary object ' '' ' ' Function saveDIC(words) Dim WshShell Set WshShell =CreateObject("WScript.Shell") WshShell.RegWrite "HKCU/Software/Mercury Interactive/QuickTest Professional/MicTest/ReservedObjects/GlobalDictionary/ProgID", "Scripting.Dictionary","REG_SZ" Set WshShell = Nothing GlobalDictionary.RemoveAll GlobalDictionary.Add "name",words ' saveDIC=mydic.Item("name") End Function '******************************************************************************************* '功能：在excel中查找一个特定的字符 '参数：testpath表示excel路径，x,y代表查找的单元格的行和列，newvalues是查找的字符 '返回值：查找到的sheet的名称 '作者：judd '******************************************************************************************* Function findSheetOfWords(filename,x,y,words) On error resume next testpath=getFilePath(filename) Set excelapp=createobject("excel.application") set xlswork=excelapp.Workbooks.Open(testpath) Set activework=excelapp.ActiveWorkbook sheetnum=activework.sheets.count For sheeta=1 to sheetnum tempdata=trim(activework.sheets(sheeta).cells(x,y)) if instr(1,tempdata,trim(words),1)<>0 then 'reportResult(teststep, expectvalue, actualvalue) reportResult "在excel中查找字符","查找到期望字符","查找到期望字符" sheetnames=activework.Sheets(sheeta).name Exit for else sheetnames="0" reportResult "在excel中查找字符","能查找到期望字符","没有查找到期望的字符" end if Next findSheetOfWords=sheetnames xlswork.Save xlswork.Close Set excelapp=nothing End Function '******************************************************************************************* '功能：测试用，观察当前运行的测试执行情况 '参数：text表示运行的弹出的提醒的文本，timeout表示等待的时候，如果在等待的时候内，对弹出窗口没有响应，则会自动关闭 '返回值:无 '作者： '******************************************************************************************* Public Sub reportProgress (Text, TimeOut) Set WshShell = CreateObject("WScript.Shell") WshShell.Popup Text, TimeOut, "测试执行过程观察器" End Sub '******************************************************************************************* '功能：导入运行中的excel数据到datatable中 '参数：filename表示指定的需要导入当前的action的名称，支持模糊输入，sheetindex表示excel的sheet的索引，srcsheetname表示需要导入的datatable对象中的sheet名称 '返回值:无 '作者：judd '******************************************************************************************* Function importDatatable(filename,sheetindex,srcsheetname) 'findPathByEnv(filename, pathtype) excelpath=getFilePath(filename) datatable.ImportSheet excelpath,sheetindex,srcsheetname End Function '******************************************************************************************* '功能：获得excel的可用区域行数 '参数：filename表示excel文件的名称，支持模糊输入，sheetindex表示excel的sheet的索引数 '返回值:excel中可用的行数（带有数据的） '作者：judd '******************************************************************************************* Function getRowRange(filename,sheetindex) On error resume next excelpath=getFilePath(filename) Set excelapps=CreateObject("Excel.Application") excelapps.Visible=false Set xlsworks=excelapps.Workbooks.Open(excelpath) Set xlssheets=xlsworks.Worksheets(sheetindex) totalrow=xlssheets.usedrange.rows.count getRowRange=totalrow xlsworks.Save xlsworks.Close Set excelapps=Nothing End Function '******************************************************************************************* '功能：清空指定的sheet的第二行起的所有内容 '参数：filename表示需要清空的excel文件名称，支持模糊文件名称，sheetindex表示需要清空的excel的sheet的索引 '返回值：无 '作者： '******************************************************************************************* Function clearSheetContent(filename,sheetindex) On error resume next excelpath=getFilePath(filename) '获取指定文件的完整路径 Set excelapps=CreateObject("Excel.Application") excelapps.Visible=false '将excel对象隐藏不要显示打开 Set xlsworks=excelapps.Workbooks.Open(excelpath) Set xlssheets=xlsworks.Worksheets(sheetindex) '获得sheet对象 trows=xlssheets.usedrange.rows.count '获得excel中的有数据的行数 'xlssheets.usedrange.clear 全部删除内容 ' xlssheets.Rows(rowt).Delete xlssheets.Range( "A1:AI"&trows).clear excelapps.Application.DisplayAlerts=false xlsworks.Save xlsworks.Close excelapps.Quit Set excelapps=Nothing End Function '******************************************************************************************* '功能：运行进程中是否存在某进程,如果有返回true,没有返回false '参数：processname:进程名 '返回值：true:有该进程，false:没有该进程 '作者：judd '******************************************************************************************* Function existProcess(processname) on error resume next set y=getobject("winmgmts:\\.\root\cimv2") 'wmi调用的方式 set ws=createobject("wscript.shell") set x=y.execquery("select * from win32_process") '查询数据表 for each i in x 'ReportProgress(Text, Title, TimeOut) If instr(1,i.Name,processname,1)<>0 Then ReportProgress i.name&"进程存在，测试需要关闭该进程，请尽快保存该进程对应的文件，系统将在10秒内强制关闭该进程",10 existProcess=true wscript.quit else existProcess=false End If next reporter.ReportEvent micDone,"判断是否存在"&processname&"进程","该进程不存在" 'existProcess=false End Function '******************************************************************************************* '功能：获得当前脚本运行机器的IP地址 '参数：无 '返回值：运行脚本的机器的IP地址 '作者：judd '******************************************************************************************* Function getIP() Set WshShell = CreateObject("WScript.Shell") Set oExec = WshShell.Exec("ipconfig.exe") Set oStdOut = oExec.StdOut ip = "" Do Until oStdOut.AtEndOfStream strLine = oStdOut.ReadLine If InStr(strLine, "本地连接") > 0 Then strLine = oStdOut.ReadLine strLine = oStdOut.ReadLine strLine = oStdOut.ReadLine ip = Mid(strLine, InStr(strLine, ":") + 2) ip=replace(ip,vbCrLf,"") Exit Do End If Loop If ip = "" Then reporter.ReportEvent micFail,"获取执行机器IP地址","获取IP地址失败" getIP=null Else getIP=trim(ip) End If End Function '******************************************************************************************* '功能：加载XML文件 '参数：ip表示共享存放文件的机器IP地址，xmlfilename表示加载的xml文件名称 '返回值：无 '作者：judd '******************************************************************************************* Function loadQTPXML(ip,xmlfilename) filepath="\\"&ip&"\ScriptDatas\XML\"&xmlfilename environment.LoadFromFile(filepath) End Function
本文转自hcy's workbench博客园博客，原文链接：http://www.cnblogs.com/alterhu/archive/2012/03/25/2416766.html
，如需转载请自行联系原作者。
