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

最新可用的源码更新如下(主要修改了对应的EXCEL的操作,修改为了单例模式进行操作EXCEL对象,使得操作excel更加的快速,而且有效);

源码如下:(本框架本博客版权所有,未经本人许可不得用于其他商业用途,转载请注明出处.谢谢)

'*******************************************************************************************
'功能:新建一个excel文件
'参数：无
'返回值：创建一个excelapp的进程
'作者：judd
'*******************************************************************************************
Function CreateExcel() 'As Excel.Application
    Dim excelSheet 'As Excel.worksheet
    Set ExcelApp = CreateObject("Excel.Application") 'Create a new excel Object
   ' ExcelApp.Workbooks.Add
    ExcelApp.Visible = false
    ExcelApp.AlertBeforeOverwriting=false
    Set CreateExcel = ExcelApp
End Function

'*******************************************************************************************
'功能：得到对应的指定文件的sheet实例对象
'参数：打开对应的一个excelapp进程对应的sheet名称
'返回值：excelapp的一个sheet对象
'作者：judd
'*******************************************************************************************
Function GetSheet(ExcelApp,sheetindex,pathtpe,filename) 'As Excel.worksheet
         On Error Resume Next
         testpath=getFilePath(pathtype,filename)    '获取需要写入的文件的路径
        ExcelApp.Visible=False
        Set GetSheet=ExcelApp.Workbooks.Open(testpath).Worksheets(sheetindex)
       On Error GoTo 0
End Function
'*******************************************************************************************
'功能:对excel中写入值
'参数：对应的excelapp的一个sheet的实例对象xlswork，sheet对象，x，行数，y，列数，values，对应的写入的值
'返回值：无
'作者：judd
'*******************************************************************************************

Function writeExcelDatas(xlswork,x,y,values)
    On error resume next
        '    xlswork.Worksheets(sheetindex).Activate
            xlswork.cells(x,y)=values
   On Error GoTo 0
End Function


'*******************************************************************************************
'功能：获取excel中指定的单元格中的数据
'参数：testpath表示需要写入数据的excel的路径，sheetname表示需要写入的excel的sheet名称，x代表excel代表单元格中的行，y代表单元格中的列
'返回值：获取你所需指定的单元格的值
'作者：judd
'*******************************************************************************************

Function readExcelDatas(xlswork,row,columny)
     value = 0
     Err = 0
     On Error Resume Next
     tempValue = xlswork.Cells(row, columny)
     If Err = 0 Then
        lastvalue = tempValue
        Err = 0
    End If
    On Error GoTo 0
    readExcelDatas = lastvalue
   ' MsgBox "successbox"
End Function


'*******************************************************************************************
'功能：删除对应的excel中的指定的行
'参数：xlswork指定的sheet对象，rownum指定的行数
'返回值：null
'作者：judd
'*******************************************************************************************
Function deleterow(xlswork,rownum)
           xlswork.rows(rownum).delete
End Function
'openAndWriteExcel "d:\maybe.xlsx",1,1,"abcziptestdddddddddddddddd"
'*******************************************************************************************
'功能:关闭excelapp进程
'参数：excelapp对应的是excel的进程对象
'返回值：无
'作者：judd
'*******************************************************************************************
Sub CloseExcel(ExcelApp)
    Set excelSheet = ExcelApp.ActiveSheet
    Set excelBook = ExcelApp.ActiveWorkbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    fso.CreateFolder "C:\Temp"
    fso.DeleteFile "C:\Temp\ExcelExamples.xls"
    excelBook.SaveAs "C:\Temp\ExcelExamples.xls"
    ExcelApp.Quit
    Set ExcelApp = Nothing
    Set fso = Nothing
    Err = 0
    On Error GoTo 0
End Sub

'*******************************************************************************************
'功能:保存已经实现的excel进程实例的sheet对象
'参数：excelApp表示对应的excel进程对象，workbookIdentifier 表示sheet的id，path表示临时保存的excel的路径，可不写为空字符
'返回值：无
'作者：judd
'*******************************************************************************************
Function SaveWorkbook(ExcelApp, workbookIdentifier, path) 'As String
    Dim workbook 'As Excel.workbook
    On Error Resume Next
    Set workbook = ExcelApp.Workbooks(workbookIdentifier)
    On Error GoTo 0
    If Not workbook Is Nothing Then
        If path = "" Or path = workbook.FullName Or path = workbook.Name Then
            workbook.Save
        Else
            Set fso = CreateObject("Scripting.FileSystemObject")
 
            'if the path has no file extension then add the 'xls' extension
            If InStr(path, ".") = 0 Then
                path = path & ".xls"
            End If
 
            On Error Resume Next
            fso.DeleteFile path
            Set fso = Nothing
            Err = 0
            On Error GoTo 0
            workbook.SaveAs path
        End If
        SaveWorkbook = "OK"
    Else
        SaveWorkbook = "Bad Workbook Identifier"
    End If
End Function

'*******************************************************************************************
'功能:比较两个excel的sheet的内容是否一致
'参数：sheet1,第一个sheet的实例sheet2第二个sheet的实例对象 startColumn第几列 numberOfColumns共计多少列 startRow, 第几行numberOfRows,共计有多少行trimed是否忽略空格
'返回值：无
'作者：judd
'*******************************************************************************************


Function CompareSheets(expectsheet, actualsheet, startColumn, numberOfColumns, startRow, numberOfRows, trimed) 'As Boolean
    Dim returnVal 'As Boolean
    Dim totaldatas
    totaldatas=numberOfColumns*numberOfRows
    print "共计有多少数据"&totaldatas
    returnVal = true
    'In case that one of the sheets doesn't exists, don't continue the process
    If expectsheet Is Nothing Or actualsheet Is Nothing Then
        CompareSheets = false
'reportResult(teststep, expectvalue, actualvalue)
        reportResult "比较对应的测试结果的两个sheet内容","两个sheet内容存在","两个sheet的内容为空，请确认sheet后再操作"

         Exit Function
    End If
 
    'loop through the table and fill values into the two worksheets
    For r = startRow to (startRow + (numberOfRows - 1))
        For c = startColumn to (startColumn + (numberOfColumns - 1))
            Value1 = expectsheet.Cells(r, c)
            Value2 = actualsheet.Cells(r, c)
 
            'if 'trimed' equels True then used would like to ignore blank spaces
            If trimed Then
                Value1 = Trim(Value1)
                
                Value2 = Trim(Value2)

            End If
           print "value expect:"&Value1
           print "value acutal:"&Value2
            'in case that the values of a cell are not equel in the two worksheets
            'create an indicator that the values are not equel and set return value
            'to False
            If Value1 <> Value2 Then
                Dim cell 'As Excel.Range
            '    print  "运行的[实际结果为:]" & Value2 & "'[,预期结果为:]" & Value1 
                reportResult "Failed:比较sheet对应的单元格值",Value1, Value2
                expectsheet.cells(r, c) = "此处结果为:[" & Value1 & "],实际结果为:[" & Value2&"]"
                Set cell = expectsheet.cells(r, c)
        '        print "当前运行"&r&"第列"&c
                cell.Font.Color = vbRed
                 returnVal = False
             else
                  reportResult "PASS:比较sheet对应的单元格值",Value1, Value2
            End If
        Next
    Next
    CompareSheets = returnVal
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   
        '    If error.number>0 Then
            'reportResult(teststep, expectvalue, actualvalue)
               '   reportResult "时间日期转换函数","转换成功","转换成功"
            
            'End If
            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)
   On error resume next
   'expectvalue="exp_"&actualvalue
   finaltime=FormateDateTime(now(),"5")
   timestamp=mid(finaltime,4,2)+mid(finaltime,7,2)
   resultpath=environment.Value("RunImgs")
   'listpath=resultpath&"\"&teststep&"---"&timestamp&".png"
   rndnum=getRandNum(1,10)
   imgpath=resultpath&"\"&teststep&"截图--"&timestamp&rndnum&".png"
   finalexpect=trim(expectvalue)
   finalactual=trim(actualvalue)
   '打印当前运行的状态。。
    writeLogs teststep
    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(pathtype,filename,oldsheetname,templatefilename,templatesheetindex)
   On error resume next
    Dim workbook 'As Excel.workbook
    Dim worksheet 'As Excel.worksheet
    excelpath=getFilePath(pathtype,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(pathtype,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的自身的环境变量进行确认相关的需要的路径
'参数：需要查询的文件的路径的文件名称,pathtype表示查询路径的类型，可选的是0,1,2,3,4
'返回值：返回查询文件的绝对路径
'*******************************************************************************************
Function  getFilePath(pathtype,filename)

        On error resume next
        Set tfso=createobject("scripting.filesystemobject")
        testfiles=environment.Value("RunLogs")
        If pathtype=0 Then
             datapath=environment.Value("TestPath")
        elseif pathtype=1 then
             datapath=environment.Value("InputData")
        elseif pathtype=2 then
             datapath=environment.Value("OutputData")
        elseif pathtype=3 then
             datapath=environment.Value("RunImgs")
        elseif pathtype=4 then
             datapath=environment.Value("RunLogs")
        else 
             datapath=environment.Value("TestPath")
        End If
        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")
  bfile=trim(filename)
   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 trim(testfile.name)
    '      print instr(1,trim(testfile.name),bfile,1)
           If instr(1,testfile.name,trim(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
                    logfile.Close
                   Set logfile=nothing
    ' Set firstsub=nothing
                   Set fso=nothing
                   Exit function 
            else
                'ReportProgress(Text, Title, TimeOut)
                 'ReportProgress "在指定的路径下没有找到你需要的文件"
                '  logfile.WriteLine testfile.path
              '    logfile.Close
               '   Set logfile=nothing
    ' Set firstsub=nothing
               '   Set fso=nothing
            '   print "没有找到对象啊"
           End If
       Next
    else
      'ReportProgress(Text, Title, TimeOut)
            reportProgress "enviroment文件中的测试路径找不到，请确认你的environment文件正确配置或者加载到QTP中，使用loadQTPXML方法进行加载XML文件到QTP中！",2
        '     logfile.WriteLine testfile.path
            logfile.Close
            Set logfile=nothing
    ' Set firstsub=nothing
             Set fso=nothing
   End If
     
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(pathtype,filename,x,y,words)
   On error resume next
   testpath=getFilePath(pathtype,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(pathtype,filename,sheetindex,srcsheetname)
'findPathByEnv(filename, pathtype)
   excelpath=getFilePath(pathtype,filename)
   datatable.ImportSheet excelpath,sheetindex,srcsheetname
End Function




'*******************************************************************************************
'功能：获得excel的可用区域行数
'参数：filename表示excel文件的名称，支持模糊输入，sheetindex表示excel的sheet的索引数
'返回值:excel中可用的行数（带有数据的）
'作者：judd
'*******************************************************************************************
Function getRowRange(xlswork)
     On error resume next
     totalrow=xlswork.usedrange.rows.count
     getRowRange=totalrow
End Function

'*******************************************************************************************
'功能：清空指定的sheet的第二行起的所有内容
'参数：filename表示需要清空的excel文件名称，支持模糊文件名称，sheetindex表示需要清空的excel的sheet的索引
'返回值：无
'作者：

'*******************************************************************************************
Function clearSheetContent(pathtype,filename,sheetindex)
    On error resume next
   excelpath=getFilePath(pathtype,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)
        'print i.name
        If instr(1,i.Name,processname,1)<>0 Then    

            '     ReportProgress  i.name&"进程存在，测试需要关闭该进程，请尽快保存该进程对应的文件，系统将在10秒内强制关闭该进程",10
                 existProcess=true        
                 Exit function 
        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
   'envs=environment.Value("TestPath")
'reportResult(teststep, expectvalue, actualvalue)
               environment.LoadFromFile(filepath)
        
            '  reportResult  "加载xml到环境中","加载成功","xml已经加载在环境中了"

End Function

'*******************************************************************************************
'功能:获得web对象中的table对象的表头列所对应的列号
'参数：obj参数表示table对象，textid表示table的标头列所在的行数，indextext表示标头列的文本，支持模糊匹配
'返回值：所在的列数
'作者：judd

'*******************************************************************************************

Function getTableColumn(obj,textid,indextext)
        Set Table=obj
        For i=1 to Table.ColumnCount(textid)
            'print "ttt:"&Table.GetCellData(textid,i)
            If instr(1,Table.GetCellData(textid,i),indextext,1)<>0 then
                columnid=i
                Exit for
            else    
                columnid=0
            end if 
        next
        getTableColumn=columnid
        Set Table=nothing
End Function
'*******************************************************************************************
'功能:获得web对象中的table对象的表头列所对应的文本数组
'参数：obj参数表示table对象，textid表示table的标头列所在的行数，indextext表示标头列的文本，支持模糊匹配
'返回值：所有的列头的文本数组对象
'作者：judd

'*******************************************************************************************
Function getTableIndexText(obj,textid)
       On error resume next
        Set Table=obj
        Set textdic=createobject("scripting.dictionary")
        For i=1 to Table.ColumnCount(textid)
            textdic.Add i,Table.GetCellData(textid,i)
        next
        getTableIndexText=textdic.Items
        Set textdic=nothing
        Set Table=nothing
End Function

'*******************************************************************************************
'功能:生成不同的action之间传值的一个全局对象
'参数：无
'返回值：无
'作者：judd
'使用实例：直接在QTP中使用DataDic即可使用该字典对象

'*******************************************************************************************


Function registerData()
   On error resume next
     Set WshShell=createobject("wscript.shell")
     WshShell.RegWrite "HKCU\Software\Mercury Interactive\QuickTest Professional\MicTest\ReservedObjects\DataDic\ProgID", "Scripting.Dictionary","REG_SZ"
     Set WshShell = Nothing
      DataDic.RemoveAll
End Function
'*******************************************************************************************
'功能：将打印日志在text文件中
'参数：teststep表示需要打印的日志内容
'返回值：无

'*******************************************************************************************
Function writeLogs(teststep)
  Const ForReading = 1, ForWriting = 2, ForAppending = 8
   Dim fso, f
   Set fso = CreateObject("Scripting.FileSystemObject")
   filepath=environment.Value("RunLogs")&"\"&teststep&"_"&formateDateTime(now,1)&".txt"
   Set f = fso.OpenTextFile(filepath, ForAppending, True)
   f.Writeline cstr(now())&"     当前测试步骤为:"&teststep
   f.Close
End Function


'*******************************************************************************************
'功能：将打印日志在text文件中
'参数：teststep表示需要打印的日志内容
'返回值：无

'*******************************************************************************************
Function writeDetailLogs(filename,teststep,inputdata)
  Const ForReading = 1, ForWriting = 2, ForAppending = 8
   Dim fso, f
   Set fso = CreateObject("Scripting.FileSystemObject")
   filepath=environment.Value("RunLogs")&"\"&filename&".txt"
   Set f = fso.OpenTextFile(filepath, ForAppending, True)
   f.Writeline cstr(now())&"     当前测试步骤为:"&teststep
   f.WriteLine "'*******************************************************************************************'***********************************************************************************"
   f.WriteLine inputdata   
   f.WriteLine "'*******************************************************************************************'***********************************************************************************"
   f.Close
End Function


'*******************************************************************************************
'功能：随机函数生成
'输入值：生成值范围 i～j
'返回值：随机数
'*******************************************************************************************
Public Function getRandNum(fromNum,toNum)
    If (fromNum<0) Or (toNum<0) Then
        MsgBox "只接受大于零的输入"
    ElseIf fromNum>toNum then
        MsgBox "起始值必须小于结束值"
    Else
        Dim RunTime
        Randomize   
        RunTime = Int((10 * Rnd) + 1) 
        Dim MyValue,i
        For i = 1 To RunTime
            Randomize  
            MyValue = Int(((toNum - fromNum + 1) * Rnd) + (fromNum))
        Next
       getRandNum=MyValue
      End If
End Function

'*******************************************************************************************
'功能：随机生成一定长度的字符串
'输入值：需要生成的字符串的长度
'返回值：字符串
'作者：judd
'*******************************************************************************************
Function randomString(inputlength)
    Dim I,x,B,A
    If IsNumeric(inputlength) Then
    For I = 1 To inputlength
        A = Array("0","1","2","3","4","5","6","7","8","9","a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z")
        Randomize 
        x=getRandNum(0,35)
        B = A(x)
        randomString =randomString +B
    Next
        randomString = randomString
    else
        msgbox ("只接受数字输入")
    End If
End Function

'*******************************************************************************************
'功能：加载页面，等待页面显示
'输入值：frameobj表示iframe对象，
'返回值：无
'作者：judd
'*******************************************************************************************
Function loadIFame(frameobj)
   Set myframe=frameobj
   While not myframe.exist(1)
        wait 3
   Wend
End Function


'*******************************************************************************************
'功能：导航页面到指定的页面中
'输入值：url表示需要导航的页面的地址
'返回值：无
'作者：judd
'*******************************************************************************************
Function navigateURL(url)
    'existProcess(processname)
      isie=existProcess("iexplore.exe")   '关闭IE进程
      If isie=True Then
          isclosed=systemutil.CloseProcessByName("iexplore.exe")
          If typename(isclosed)="Long" Then
'reportResult(teststep, expectvalue, actualvalue)
                reportResult "关闭IE进程中","关闭成功","关闭成功"&isclosed
           else
        'reportResult(teststep, expectvalue, actualvalue)
                  reportResult "关闭IE进程中","关闭成功","关闭失败"&isclosed
    
          End If
      End If
      wait  5
       systemutil.Run "iexplore.exe",url,"","",3
End Function

'*******************************************************************************************
' 函 数名: CloseBrowsers
' 功能说明: 关闭所有IE浏览器
' 参  数 1: 无
' 返 回值: 无
' 附加说明: 无
' 举例说明: CloseBrowsers()
'*******************************************************************************************

Public Function CloseBrowsers()
    On Error Resume Next
    If Browser("micclass:=Browser").Exist (0) Then
         Browser("micclass:=Browser").Close
    End If
    While Browser("micclass:=Browser", "index:=1").Exist (0)
         Browser("index:=1").Close
    Wend
    If Browser("micclass:=Browser").Exist (0) Then'再次关闭IE，防止前面过程还有IE没有关闭掉
        Browser("micclass:=Browser").Close
    End If
    CloseBrowsers = true
End Function

'*******************************************************************************************
'功能：值交换函数
'参数：a第一个数，b第二个数
'返回值：无
'作者：
'*******************************************************************************************
Public Sub swapNumbers(byref a,byref b)
    Dim c
    c = a
    a = b
    b = c
End Sub 
'*******************************************************************************************
'功能：去掉字符串中的重复项
'参数：inp字符串，sp重复的字符
'返回值：无重复的字符串
'作者：judd
'*******************************************************************************************

Function NoRepeat(Inp,Sp)
Dim aa,flag,words,length,i,j,k,sp1,sp2,cc
    aa = Inp
    Do 
        flag = False 
        words = Split(aa,Sp)
        length = UBound(words)
        For i = 0 To (length -1)
            sp1 = words(i)
            For j = (i+1) To length
                sp2 = words(j)
                If sp1 = sp2 Then
                    flag = True
                    aa = ""
                    For k = 0 To (j-1)
                        aa = aa & words(k) & sp
                    Next
                    For k = (j + 1) To length
                        aa = aa & words(k) & sp
                    Next
                    
                    cc = Len(aa)
                    aa = Left(aa,(cc - 1)) 
                End If 
            Next 
            If flag = True Then
                Exit For
            End if
        Next 
    Loop Until flag = false
    NoRepeat = aa
End Function
'*******************************************************************************************