QTP的那些事—QTP11+QC11框架整理源码（个人原创）

这部分代码是个人整理的个人使用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&"---"&timestamp&".png"
   imgpath=resultpath&"\"&teststep&"截图--"&timestamp&".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