QTP 常用函数总结

'获取当前日期

Public Function Get_Date()

 Dim currentDate

 currentDate = Date

 Get_Date = currentDate

End Function

'调用

print Get_Date()

'获取当前时间

Public Function Get_Time()

 Dim currentTime

 currentTime = Time

 Get_Time = currentTime

End Function

'调用

print Get_Time

'随机函数生成

'输入值：生成值范围 i～j

'返回值：随机数

Public Function Get_RandNum(fromNum,toNum)

 If (fromNum<0) Or (toNum<0) Then

    MsgBox "只接受大于零的输入"

 ElseIf fromNum>toNum then

    MsgBox "起始值必须小于结束值"

 Else

    Dim RunTime

    Randomize  '初始化随机生成器，该生成器具有根据系统计时器得到的随机种子

    RunTime = Int((10 * Rnd) + 1) 'Rnd本身的值是由随机种子得到的介于0--1之间的随机数

    Dim MyValue,i

    For i = 1 To RunTime

      Randomize 

      MyValue = Int(((toNum - fromNum + 1) * Rnd) + (fromNum))

    Next

      Get_randNum=MyValue

 End If

End Function

'调用

print Get_RandNum(0,100)

'值交换函数

Public Sub swap(byref a,byref b)

 Dim c

 c = a

 a = b

 b = c

End Sub

'调用

Dim a,b

a=3

b=6

swap a,b

print "a="&a

print "b="&b

'是质数返回true，否则返回false

Function IsPrimeNumber(num)

 Dim i,flag

 flag = true

 If num = 1 Then

  flag = False

 ElseIf num < 1 Then

  MsgBox "只能接受大于0的数"

  flag = False

 Else

  For i = 2 To (num - 1)

   If ((num Mod i) = 0) Then

    flag = False

    Exit For

   End If

  Next

 End If

 IsPrimeNumber = flag

End Function

'调用

 print IsPrimeNumber(7)

'读指定文本文件指定行内容

Function ReadLine(pathway, rowcount)

 Dim fso,myfile,i,flag

 flag = 1

 Set fso=CreateObject("scripting.FileSystemObject")

 If fso.FileExists(pathway) then

  Set myfile = fso.openTextFile(pathway,1,false)

 Else

  flag = 0

 End If

 

 For i=1 to rowcount-1

  If Not myfile.AtEndOfLine Then

   myfile.SkipLine

  End If

 Next

 

 If flag = 1 then

  If Not myfile.AtEndOfLine Then

   ReadLine = myfile.ReadLine

  Else

   ReadLine = "文本越界"

  End If

  myfile.close

 Else

  ReadLine = "文件不存在"

 End If

End Function

'调用

print ReadLine("E:\zhang\QTP\vbs.txt", 3)

'随机生成字符串，需要用到上边的随机数函数

Function MakeString(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=Get_RandNum(0,35)

  B = A(x)

  makestring =makestring +B

 Next

  MakeString = makestring

 else

  msgbox ("只接受数字输入")

 End If

End Function

'调用

print MakeString(5)

'启动资源管理器

Sub ZYGLQ()

 Dim WshShell

 set WshShell = CreateObject("Wscript.Shell")

 WshShell.SendKeys "^+{ESC}"

 Set WshShell = nothing

End Sub

'启动运行

Sub Run()

 Dim WshShell

 set WshShell = CreateObject("Wscript.Shell")

 WshShell.SendKeys "^{ESC}R"

 Set WshShell = nothing

End Sub

'发送电子邮件

Function SendMail(SendTo, Subject, Body, Attachment)

 Dim ol,mail

    Set l=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 l = Nothing

End Function

'去掉字符串中的重复项

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

'求字符串长度（中文算2个西文字符）

Function GetLen(Str)

        Dim singleStr, i, iCount

        iCount = 0

        For i = 1 to len(Str)

                singleStr = mid(Str,i,1)

                If asc(singleStr) < 0 Then

                        iCount = iCount + 2

                Else

                        iCount = iCount + 1

                End If  

        Next

        GetLen = iCount

End Function

'运行指定程序

Sub RunApp(command)

 Dim WshShell

 set WshShell = CreateObject("Wscript.Shell")

 WshShell.Exec command

End Sub

'求下一天是几号的函数

Function Nextday(ByVal inputday)

    Dim temp, num, OPYear, OPMonth, OPDay, ret, flag

    temp = Split(CStr(inputday), "-")

    num = UBound(temp) + 1

    PYear = temp(0)

    PMonth = temp(1)

    PDay = temp(2)

    flag = 0

    If PMonth = 1 Or PMonth = 3 Or PMonth = 5 Or PMonth = 7 Or PMonth = 8 Or PMonth = 10 Or PMonth = 12 Then

        If OPDay > 31 Or OPDay < 1 Then

            flag = 1

        End If

    ElseIf PMonth = 4 Or PMonth = 6 Or PMonth = 9 Or PMonth = 11 Then

        If OPDay > 30 Or OPDay < 1 Then

            flag = 1

        End If

    Else

        If ISLeapYear(OPYear) Then

            If OPDay > 29 Or OPDay < 1 Then

                flag = 1

            End If

        Else

            If OPDay > 28 Or OPDay < 1 Then

                flag = 1

            End If

        End If

    End If

    If flag = 1 Or num <> 3 Then

        MsgBox "输入参数不对劲", , "Nextday函数提示"

    Else

        If PMonth = 1 Or PMonth = 3 Or PMonth = 5 Or PMonth = 7 Or PMonth = 8 Or PMonth = 10 Or PMonth = 12 Then 'big month

            If PDay = 31 Then

                PDay = 1

                If PMonth = 12 Then

                    PMonth = 1

                    PYear = OPYear + 1

                Else

                    PMonth = OPMonth + 1

                    PYear = OPYear

                End If

            Else

                PDay = OPDay + 1

            End If

        ElseIf PMonth = 4 Or PMonth = 6 Or PMonth = 9 Or PMonth = 11 Then                                          'small month

            If PDay = 30 Then

                PDay = 1

                If PMonth = 12 Then

                    PMonth = 1

                    PYear = OPYear + 1

                Else

                    PMonth = OPMonth + 1

                    PYear = OPYear

                End If

            Else

                PDay = OPDay + 1

            End If

        Else                                                                                                           'February

            If ISLeapYear(OPYear) Then

                If PDay = 29 Then

                    PDay = 1

                    If PMonth = 12 Then

                        PMonth = 1

                        PYear = OPYear + 1

                    Else

                        PMonth = OPMonth + 1

                        PYear = OPYear

                    End If

                Else

                    PDay = OPDay + 1

                End If

            Else

                If PDay = 28 Then

                    PDay = 1

                    If PMonth = 12 Then

                        PMonth = 1

                        PYear = OPYear + 1

                    Else

                        PMonth = OPMonth + 1

                        PYear = OPYear

                    End If

                Else

                    PDay = OPDay + 1

                End If

            End If

        End If

        ret = OPYear & "-" & OPMonth & "-" & OPDay

        Nextday = ret

    End If

End Function

'是否闰年

Function ISLeapYear(ByVal inYear)

    If ((inYear Mod 4 = 0 And inYear Mod 100 <> 0) Or inYear Mod 400 = 0) Then

        ISLeapYear = True

    Else

        ISLeapYear = False

    End If

End Function

'计算两个日期之间相隔几天

Function Days(ByVal SourceData, ByVal DesData)

    Dim flag, temp1, temp2, OPYear1, OPYear2, OPMonth1, OPMonth2, OPDay1, OPDay2, i, tempDay

    temp1 = Split(SourceData, "-")

    temp2 = Split(DesData, "-")

    If ((UBound(temp1) + 1) <> 3) Or ((UBound(temp2) + 1) <> 3) Then

        MsgBox "输入参数不对劲", , "Days函数提示"

    End If

    OPYear1 = temp1(0)

    OPMonth1 = temp1(1)

    OPDay1 = temp1(2)

    OPYear2 = temp2(0)

    OPMonth2 = temp2(1)

    OPDay2 = temp2(2)

    If CInt(OPYear1) <> CInt(OPYear2) Then

        If CInt(OPYear1) > CInt(OPYear2) Then

            flag = "big"

        ElseIf CInt(OPYear1) < CInt(OPYear2) Then

            flag = "small"

        End If

    Else

        If CInt(OPMonth1) <> CInt(OPMonth2) Then

            If CInt(OPMonth1) > CInt(OPMonth2) Then

                flag = "big"

            ElseIf CInt(OPMonth1) < CInt(OPMonth2) Then

                flag = "small"

            End If

        Else

            If CInt(OPDay1) <> CInt(OPDay2) Then

                If CInt(OPDay1) > CInt(OPDay2) Then

                    flag = "big"

                ElseIf CInt(OPDay1) < CInt(OPDay2) Then

                    flag = "small"

                End If

            Else

                flag = "="

            End If

        End If

    End If

    If (flag = "big") Then

        i = 1

        tempDay = DesData

        Do

            tempDay = Nextday(tempDay)

            i = i + 1

        Loop Until tempDay = SourceData

        i = i - 1

    ElseIf (flag = "small") Then

        i = 1

        tempDay = SourceData

        Do

            tempDay = Nextday(tempDay)

            i = i + 1

        Loop Until tempDay = DesData

        i = i - 1

    Else

        i = 0

    End If

    Days = i

End Function

'检查身份证号是否正确

Function Identification(Text1)

xian = Text1

If (Not IsNumeric(Left(Text1, 15)) And Not IsNumeric(Left(Text1, 18))) Or Text1 = "" Then

  Identification = False

  Exit Function

End If

lenx = Len(Trim(Text1))

If lenx = 15 Or lenx = 18 Then

    If lenx = 15 Then

        yy = "19" & Mid(xian, 7, 2)

        mm = Mid(xian, 9, 2)

        dd = Mid(xian, 11, 2)

        aa = Right(xian, 1)

    End If

    If lenx = 18 Then

        yy = Mid(xian, 7, 4)

        mm = Mid(xian, 11, 2)

        dd = Mid(xian, 13, 2)

        aa = Right(xian, 1)

    End If

    If CInt(mm) > 12 Or CInt(dd) > 31 Then

       Identification = False

       Exit Function

    Else

     Identification = True

     Exit Function

    End If

Else

  Identification = False

  Exit Function

End If

End Function

'检查是否存在数字

Function checkString (myString)

 checkString = False

 Dim myChr

 For myChr = 48 to 57

  If InStr(myString,Chr(myChr)) > 0 Then

   checkString = True

   Exit Function

  End If

 Next

End Function

'查询Access数据库字符出现次数

Function Access_GetCount(DBlocation,TableName,Value)

 set con=createobject("adodb.connection")

 con.open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & DBlocation

 set record = createobject("adodb.recordset")

 sql="select * from " & TableName

 

 record.open sql,con

 DO

  if(record("name")=Value)then

   num=num+1

  end If

  record.MoveNext

 loop until record.eof=True

 

 record.close

 set record=Nothing

 con.close

 set con=Nothing

 

 If num = 0 Then

  Access_GetCount = 0

 Else

  Access_GetCount = num

 End If

End Function

'按ASCII码值冒泡排序

Function BubbleSort(VString,Spl,Func)

 Dim Str,StrLength,i,j

 Str = Split(VString,Spl)

 StrLength = UBound(Str) + 1

 For i = 1 To (StrLength-1)

  For j = (i+1) To StrLength

   If Func = 1 then

    If Asc(Str(i-1)) < Asc(Str(j-1)) Then

     Call Swap(Str(i-1),Str(j-1))

    End If

   Else

    If Asc(Str(i-1)) > Asc(Str(j-1)) Then

     Call Swap(Str(i-1),Str(j-1))

    End If

   End If

  Next

 Next

 j = ""

 For i = 1 To StrLength

  j = j & Str(i-1) & Spl

 Next

 j = Left(j,(StrLength * 2 -1))

 BubbleSort = j

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''以下为仅QuickTest适用函数'''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'让QTP运行时保持最小化

Public Sub QTP_Small()

 Dim objQTPWin

 Set bjQTPWin = GetObject("" , "QuickTest.Application")

 objQTPWin.WindowState = "Minimized"

 Set bjQTPWin = Nothing

End Sub

'恢复QTP窗口

Public Sub QTP_Big()

 Dim objQTPWin

 Set bjQTPWin = GetObject("" , "QuickTest.Application")

 objQTPWin.WindowState = "Restored"

 Set bjQTPWin = Nothing

End Sub

'写文件函数(追加)

'输入值：写入内容

Public Function QTP_WriteFile(pathway,words)

    Dim fileSystemObj,fileSpec,logFile,way

    Set fileSystemObj = CreateObject("Scripting.FileSystemObject")

    fileSpec = pathway

    Set logFile = fileSystemObj.OpenTextFile(fileSpec, 8, true)

    logFile.WriteLine (CStr(words))

    logFile.Close

    Set logFile = Nothing

End Function

'写文件函数(改写)

'输入值：写入内容

Public Function QTP_WriteFile_Change(pathway,words)

    Dim fileSystemObj,fileSpec,logFile,way

    Set fileSystemObj = CreateObject("Scripting.FileSystemObject")

    fileSpec = pathway

    Set logFile = fileSystemObj.OpenTextFile(fileSpec, 2, true)

    logFile.WriteLine (CStr(words))

    logFile.Close

    Set logFile = Nothing

End Function

'读Excel文件元素

Public Function QTP_Read_Excel(pathway,sheetname,x,y)

 Dim srcData,srcDoc,ret

 set srcData = CreateObject("Excel.Application")

 srcData.Visible = True

 set srcDoc = srcData.Workbooks.Open(pathway)

 srcDoc.Worksheets(sheetname).Activate

 ret = srcDoc.Worksheets(sheetname).Cells(x,y).value

 srcData.Workbooks.Close

 Window("text:=Microsoft Excel").Close

 QTP_Read_Excel = ret

End Function

'写Excel文件元素并保存退出

Public Function QTP_Write_Excel(pathway,sheetname,x,y,content)

 Dim srcData,srcDoc,sp1,sp2,num,use,a1,a2,a3

 set srcData = CreateObject("Excel.Application")

 srcData.Visible = True

 set srcDoc = srcData.Workbooks.Open(pathway)

 srcDoc.Worksheets(sheetname).Activate

 srcDoc.Worksheets(sheetname).Cells(x,y).value = content

 

' sp1 = Split(pathway,".")

' sp2 = Split(sp1(0),"\")

' num = UBound(sp2)

' use = sp2(num)

' Set a1 = Description.Create()

' a1("text").value="Microsoft Excel - " + use + ".xls"

' a1("window id").value="0"

' Set a3 = Description.Create()

' a3("Class Name").value="WinObject"

' a3("text").value= use + ".xls"

' Window(a1).WinObject(a3).Type micCtrlDwn + "s" + micCtrlUp

 Dim WshShell

 Set WshShell=CreateObject("Wscript.Shell")

 WshShell.SendKeys "^s"

 wait(1)

 

 srcData.Workbooks.Close

 Set srcDoc = nothing

 

 Window("text:=Microsoft Excel").Close

End Function

'定时停留弹出框函数

Sub QTP_Msgbox(Value,waitTime,Title)

 Dim WshShell

    Set WshShell = CreateObject("WScript.Shell")

    WshShell.Popup Value, waitTime, Title

    Set WshShell = nothing

End Sub

'改变Excel的单元格颜色

Public Function QTP_Change_Color(pathway,sheetname,x,y,color)

 Dim srcData,srcDoc,sp1,sp2,num,use,a1,a2,a3

 set srcData = CreateObject("Excel.Application")

 srcData.Visible = True

 set srcDoc = srcData.Workbooks.Open(pathway)

 srcDoc.Worksheets(sheetname).Activate

 If color = "red" Then

  srcDoc.Worksheets(sheetname).Cells(x,y).Interior.color=vbred

 ElseIf color = "green" Then

  srcDoc.Worksheets(sheetname).Cells(x,y).Interior.color=vbgreen

 Else

  MsgBox "输入的颜色参数不正确，只接收""red""和""green"""

 End If

 Dim WshShell

 Set WshShell=CreateObject("Wscript.Shell")

 WshShell.SendKeys "^s"

 wait(1)

 

 srcData.Workbooks.Close

 Set srcDoc = nothing

 Window("text:=Microsoft Excel").Close

End Function

'捕获当前屏幕（截图）

Public Function QTP_Capture(pathway)

  Dim datestamp

  Dim filename

  datestamp = Now()

  filename = Environment("TestName")&"_"&datestamp&".png"

  filename = Replace(filename,"/","")

  filename = Replace(filename,":","")

  filename = pathway + "\" + ""&filename

  Desktop.CaptureBitmap filename

  'Reporter.ReportEvent micFail,"image","<img src='" & filename & "'>"

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''QuickTestPlus 帮助文件对于Excel库函数  仅QTP适用''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim ExcelApp 'As Excel.Application

Dim excelSheet 'As Excel.worksheet

Dim excelBook 'As Excel.workbook

Dim fso 'As Scripting.FileSystemObject

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 = True

    Set CreateExcel = ExcelApp

End Function

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

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 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 = 1

    Else

        SaveWorkbook = 0

    End If

End Function

Sub SetCellValue(excelSheet, row, column, value)

    On Error Resume Next

    excelSheet.Cells(row, column) = value

    On Error GoTo 0

End Sub

Function GetCellValue(excelSheet, row, column)

    value = 0

    Err = 0

    On Error Resume Next

    tempValue = excelSheet.Cells(row, column)

    If Err = 0 Then

        value = tempValue

        Err = 0

    End If

    On Error GoTo 0

    GetCellValue = value

End Function

Function GetSheet(ExcelApp, sheetIdentifier) 'As Excel.worksheet

    On Error Resume Next

    Set GetSheet = ExcelApp.Worksheets.Item(sheetIdentifier)

    On Error GoTo 0

End Function

Function InsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName) 'As Excel.worksheet

    Dim workbook 'As Excel.workbook

    Dim worksheet 'As Excel.worksheet

    'In case that the workbookIdentifier is empty we will work on the active workbook

    If workbookIdentifier = "" Then

        Set workbook = ExcelApp.ActiveWorkbook

    Else

        On Error Resume Next

        Err = 0

        Set workbook = ExcelApp.Workbooks(workbookIdentifier)

        If Err <> 0 Then

            Set InsertNewWorksheet = Nothing

            Err = 0

            Exit Function

        End If

        On Error GoTo 0

    End If

    sheetCount = workbook.Sheets.Count

    workbook.Sheets.Add , sheetCount

    Set worksheet = workbook.Sheets(sheetCount + 1)

    If sheetName <> "" Then

        worksheet.Name = sheetName

    End If

    Set InsertNewWorksheet = worksheet

End Function

Function CreateNewWorkbook(ExcelApp)

    Set NewWorkbook = ExcelApp.Workbooks.Add()

    Set CreateNewWorkbook = NewWorkbook

End Function

Function OpenWorkbook(ExcelApp, path)

    On Error Resume Next

    Set NewWorkbook = ExcelApp.Workbooks.Open(path)

    Set penWorkbook = NewWorkbook

    On Error GoTo 0

End Function

Sub ActivateWorkbook(ExcelApp, workbookIdentifier)

    On Error Resume Next

    ExcelApp.Workbooks(workbookIdentifier).Activate

    On Error GoTo 0

End Sub

Sub CloseWorkbook(ExcelApp, workbookIdentifier)

    On Error Resume Next

    ExcelApp.Workbooks(workbookIdentifier).Close

    On Error GoTo 0

End Sub

Function CompareSheets(sheet1, sheet2, startColumn, numberOfColumns, startRow, numberOfRows, trimed) 'As Boolean

    Dim returnVal 'As Boolean

    returnVal = True

    If sheet1 Is Nothing Or sheet2 Is Nothing Then

        CompareSheets = False

        Exit Function

    End If

    For r = startRow to (startRow + (numberOfRows - 1))

        For c = startColumn to (startColumn + (numberOfColumns - 1))

            Value1 = sheet1.Cells(r, c)

            Value2 = sheet2.Cells(r, c)

            If trimed Then

                Value1 = Trim(Value1)

                Value2 = Trim(Value2)

            End If

            If Value1 <> Value2 Then

                Dim cell 'As Excel.Range

                sheet2.Cells(r, c) = "Compare conflict - Value was '" & Value2 & "', Expected value is '" & Value1 & "'."

                Set cell = sheet2.Cells(r, c)

                cell.Font.Color = vbRed

                returnVal = False

            End If

        Next

    Next

    CompareSheets = returnVal

End Function

'写入word文件

Sub QTP_WriteWord(pathway,content)

 Dim oWord,oRange,oDoc

 Set Word = CreateObject("Word.Application")

 oWord.documents.open pathway,forwriting, True

 Set Doc = oWord.ActiveDocument

 Set Range = oDoc.content

 oRange.insertafter content

 oWord.ActiveDocument.Save

' Dim WshShell

' Set WshShell=CreateObject("Wscript.Shell")

' WshShell.SendKeys "^s"

' wait(1)

    oWord.Application.Quit True

 Set Range = Nothing

 Set Doc = Nothing

 Set Word = Nothing

End Sub