QTP常用函数

'''以下为QuickTest和Robot都适用函数''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''获取当前日期Public Function Get_Data()Dim currentDatecurrentDate = DateGet_Data = currentDateEnd Function'获取当前时间Public Function Get_Time()Dim currentTimecurrentTime = TimeGet_Time = currentTimeEnd Function'随机函数生成'输入值：生成值范围i～j'返回值：随机数Public Function Get_RandNum(fromNum,toNum)If (fromNum<0) Or (toNum<0) ThenMsgBox "只接受大于零的输入"ElseIf fromNum>toNum thenMsgBox "起始值必须小于结束值"ElseDim RunTimeRandomizeRunTime = Int((10 * Rnd) + 1)Dim MyValue,iFor i = 1 To RunTimeRandomizeMyValue = Int(((toNum - fromNum + 1) * Rnd) + (fromNum)) NextGet_randNum=MyValueEnd IfEnd Function'值交换函数Public Sub swap(byref a,byref b)Dim cc = aa = bb = cEnd Sub'是否是质数函数'是质数返回true，否则返回false Function IsPrimeNumber(num)Dim i,flagflag = trueIf num = 1 Thenflag = FalseElseIf num < 1 ThenMsgBox "只能接受大于0的数"flag = FalseElseFor i = 2 To (num - 1)If ((num Mod i) = 0) Thenflag = FalseExit ForEnd IfNextEnd IfIsPrimeNumber = flagEnd Function'读指定文本文件指定行内容Function ReadLine(pathway, rowcount) Dim fso,myfile,i,flagflag = 1Set fso=CreateObject("scripting.FileSystemObject")If fso.FileExists(pathway) thenSet myfile = fso.openTextFile(pathway,1,false)Elseflag = 0End IfFor i=1 to rowcount-1If Not myfile.AtEndOfLine Thenmyfile.SkipLineEnd IfNextIf flag = 1 thenIf Not myfile.AtEndOfLine ThenReadLine = myfile.ReadLineElseReadLine = "文本越界"End Ifmyfile.closeElseReadLine = "文件不存在"End IfEnd Function'随机生成字符串Function MakeString(inputlength)Dim I,x,B,AIf IsNumeric(inputlength) ThenFor I = 1 To inputlengthA =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")Randomizex=Get_RandNum(0,35)B = A(x)makestring =makestring +BNextMakeString = makestringelsemsgbox ("只接受数字输入")End IfEnd Function'启动资源管理器Sub ZYGLQ()Dim WshShellset WshShell = CreateObject("Wscript.Shell")WshShell.SendKeys "^+{ESC}"Set WshShell = nothingEnd Sub'启动运行Sub Run()Dim WshShellset WshShell = CreateObject("Wscript.Shell")WshShell.SendKeys "^{ESC}R"Set WshShell = nothingEnd Sub'发送电子邮件Function SendMail(SendTo, Subject, Body, Attachment) Dim ol,mailSet ol=CreateObject("Outlook.Application")Set Mail=ol.CreateItem(0)Mail.to=SendToMail.Subject=SubjectMail.Body=BodyIf (Attachment <> "") ThenMail.Attachments.Add(Attachment)End IfMail.Sendol.QuitSet Mail = NothingSet ol = NothingEnd Function'去掉字符串中的重复项Function NoRepeat(Inp,Sp)Dim aa,flag,words,length,i,j,k,sp1,sp2,cc aa = InpDoflag = Falsewords = Split(aa,Sp)length = UBound(words)For i = 0 To (length -1)sp1 = words(i)For j = (i+1) To lengthsp2 = words(j)If sp1 = sp2 Thenflag = Trueaa = ""For k = 0 To (j-1)aa = aa & words(k) & spNextFor k = (j + 1) To lengthaa = aa & words(k) & spNextcc = Len(aa)aa = Left(aa,(cc - 1))End IfNextIf flag = True ThenExit ForEnd ifNextLoop Until flag = falseNoRepeat = aaEnd Function'求字符串长度（中文算2个西文字符）Function GetLen(Str)Dim singleStr, i, iCountiCount = 0For i = 1 to len(Str)singleStr = mid(Str,i,1)If asc(singleStr) < 0 TheniCount = iCount + 2ElseiCount = iCount + 1End IfNextGetLen = iCountEnd Function'运行指定程序Sub RunApp(command)Dim WshShellset WshShell = CreateObject("Wscript.Shell")WshShell.Exec commandEnd Sub'求下一天是几号的函数Function Nextday(ByVal inputday)Dim temp, num, OPYear, OPMonth, OPDay, ret, flag temp = Split(CStr(inputday), "-")num = UBound(temp) + 1OPYear = temp(0)OPMonth = temp(1)OPDay = temp(2)flag = 0If OPMonth = 1 Or OPMonth = 3 Or OPMonth = 5 Or OPMonth = 7 Or OPMonth = 8 Or OPMonth = 10 Or OPMonth = 12 ThenIf OPDay > 31 Or OPDay < 1 Thenflag = 1End IfElseIf OPMonth = 4 Or OPMonth = 6 Or OPMonth = 9 Or OPMonth = 11 Then If OPDay > 30 Or OPDay < 1 Thenflag = 1End IfElseIf ISLeapYear(OPYear) ThenIf OPDay > 29 Or OPDay < 1 Thenflag = 1End IfElseIf OPDay > 28 Or OPDay < 1 Thenflag = 1End IfEnd IfEnd IfIf flag = 1 Or num <> 3 ThenMsgBox "输入参数不对劲", , "Nextday函数提示"ElseIf OPMonth = 1 Or OPMonth = 3 Or OPMonth = 5 Or OPMonth = 7 Or OPMonth = 8 Or OPMonth = 10 Or OPMonth = 12 Then 'big monthIf OPDay = 31 ThenOPDay = 1If OPMonth = 12 ThenOPMonth = 1OPYear = OPYear + 1ElseOPMonth = OPMonth + 1OPYear = OPYearEnd IfElseOPDay = OPDay + 1End IfElseIf OPMonth = 4 Or OPMonth = 6 Or OPMonth = 9 Or OPMonth = 11Then 'small monthIf OPDay = 30 ThenOPDay = 1If OPMonth = 12 ThenOPMonth = 1OPYear = OPYear + 1ElseOPMonth = OPMonth + 1OPYear = OPYearEnd IfElseOPDay = OPDay + 1End IfElse 'February If ISLeapYear(OPYear) ThenIf OPDay = 29 ThenOPDay = 1If OPMonth = 12 ThenOPMonth = 1OPYear = OPYear + 1ElseOPMonth = OPMonth + 1OPYear = OPYearEnd IfElseOPDay = OPDay + 1End IfElseIf OPDay = 28 ThenOPDay = 1If OPMonth = 12 ThenOPMonth = 1OPYear = OPYear + 1ElseOPMonth = OPMonth + 1OPYear = OPYearEnd IfElseOPDay = OPDay + 1End IfEnd IfEnd Ifret = OPYear & "-" & OPMonth & "-" & OPDayNextday = retEnd IfEnd Function'是否闰年Function ISLeapYear(ByVal inYear)If ((inYear Mod 4 = 0 And inYear Mod 100 <> 0) Or inYear Mod 400 = 0) Then ISLeapYear = TrueElseISLeapYear = FalseEnd IfEnd Function'计算两个日期之间相隔几天Function Days(ByVal SourceData, ByVal DesData)Dim flag, temp1, temp2, OPYear1, OPYear2, OPMonth1, OPMonth2, OPDay1, OPDay2, i, tempDaytemp1 = Split(SourceData, "-")temp2 = Split(DesData, "-")If ((UBound(temp1) + 1) <> 3) Or ((UBound(temp2) + 1) <> 3) Then MsgBox "输入参数不对劲", , "Days函数提示"End IfOPYear1 = temp1(0)OPMonth1 = temp1(1)OPDay1 = temp1(2)OPYear2 = temp2(0)OPMonth2 = temp2(1)OPDay2 = temp2(2)If CInt(OPYear1) <> CInt(OPYear2) ThenIf CInt(OPYear1) > CInt(OPYear2) Thenflag = "big"ElseIf CInt(OPYear1) < CInt(OPYear2) Then flag = "small"End IfElseIf CInt(OPMonth1) <> CInt(OPMonth2) Then If CInt(OPMonth1) > CInt(OPMonth2) Then flag = "big"ElseIf CInt(OPMonth1) < CInt(OPMonth2) Then flag = "small"End IfElseIf CInt(OPDay1) <> CInt(OPDay2) ThenIf CInt(OPDay1) > CInt(OPDay2) Thenflag = "big"ElseIf CInt(OPDay1) < CInt(OPDay2) Then flag = "small"End IfElseflag = "="End IfEnd IfEnd IfIf (flag = "big") Theni = 1tempDay = DesDataDotempDay = Nextday(tempDay)i = i + 1Loop Until tempDay = SourceDatai = i - 1ElseIf (flag = "small") Theni = 1tempDay = SourceDataDotempDay = Nextday(tempDay)i = i + 1Loop Until tempDay = DesDatai = i - 1Elsei = 0End IfDays = iEnd Function'检查身份证号是否正确Function Identification(Text1)xian = Text1If (Not IsNumeric(Left(Text1, 15)) And Not IsNumeric(Left(Text1, 18))) Or Text1 = "" Then Identification = FalseExit FunctionEnd Iflenx = Len(Trim(Text1))If lenx = 15 Or lenx = 18 ThenIf lenx = 15 Thenyy = "19" & Mid(xian, 7, 2)mm = Mid(xian, 9, 2)dd = Mid(xian, 11, 2)aa = Right(xian, 1)End IfIf lenx = 18 Thenyy = Mid(xian, 7, 4)mm = Mid(xian, 11, 2)dd = Mid(xian, 13, 2)aa = Right(xian, 1)End IfIf CInt(mm) > 12 Or CInt(dd) > 31 ThenIdentification = FalseExit FunctionElseIdentification = TrueExit FunctionEnd IfElseIdentification = FalseExit FunctionEnd IfEnd Function'检查是否存在数字Function checkString (myString)checkString = FalseDim myChrFor myChr = 48 to 57If InStr(myString,Chr(myChr)) > 0 ThencheckString = TrueExit FunctionEnd IfNextEnd 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 " & TableNamerecord.open sql,conDOif(record("name")=Value)thennum=num+1end Ifrecord.MoveNextloop until record.eof=Truerecord.closeset record=Nothingcon.closeset con=NothingIf num = 0 ThenAccess_GetCount = 0ElseAccess_GetCount = numEnd IfEnd Function'按ASCII码值冒泡排序Function BubbleSort(VString,Spl,Func) Dim Str,StrLength,i,jStr = Split(VString,Spl)StrLength = UBound(Str) + 1For i = 1 To (StrLength-1)For j = (i+1) To StrLengthIf Func = 1 thenIf Asc(Str(i-1)) < Asc(Str(j-1)) Then Call Swap(Str(i-1),Str(j-1))End IfElseIf Asc(Str(i-1)) > Asc(Str(j-1)) Then Call Swap(Str(i-1),Str(j-1))End IfEnd IfNextNextj = ""For i = 1 To StrLengthj = j & Str(i-1) & SplNextj = Left(j,(StrLength * 2 -1))BubbleSort = jEnd Function''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''以下为仅QuickTest适用函数'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''让QTP运行时保持最小化Public Sub QTP_Small()Dim objQTPWinSet objQTPWin = GetObject("" , "QuickTest.Application")objQTPWin.WindowState = "Minimized"Set objQTPWin = NothingEnd Sub'恢复QTP窗口Public Sub QTP_Big()Dim objQTPWinSet objQTPWin = GetObject("" , "QuickTest.Application")objQTPWin.WindowState = "Restored"Set objQTPWin = NothingEnd Sub'写文件函数(追加)'输入值：写入内容Public Function QTP_WriteFile(pathway,words)Dim fileSystemObj,fileSpec,logFile,waySet fileSystemObj = CreateObject("Scripting.FileSystemObject") fileSpec = pathwaySet logFile = fileSystemObj.OpenTextFile(fileSpec, 8, true)logFile.WriteLine (CStr(words))logFile.CloseSet logFile = NothingEnd Function'写文件函数(改写)'输入值：写入内容Public Function QTP_WriteFile_Change(pathway,words) Dim fileSystemObj,fileSpec,logFile,waySet fileSystemObj = CreateObject("Scripting.FileSystemObject") fileSpec = pathwaySet logFile = fileSystemObj.OpenTextFile(fileSpec, 2, true)logFile.WriteLine (CStr(words))logFile.CloseSet logFile = NothingEnd Function'读Excel文件元素Public Function QTP_Read_Excel(pathway,sheetname,x,y)Dim srcData,srcDoc,retset srcData = CreateObject("Excel.Application")srcData.Visible = Trueset srcDoc = srcData.Workbooks.Open(pathway)srcDoc.Worksheets(sheetname).Activateret = srcDoc.Worksheets(sheetname).Cells(x,y).valuesrcData.Workbooks.CloseWindow("text:=Microsoft Excel").CloseQTP_Read_Excel = retEnd Function'写Excel文件元素并保存退出Public Function QTP_Write_Excel(pathway,sheetname,x,y,content) Dim srcData,srcDoc,sp1,sp2,num,use,a1,a2,a3set srcData = CreateObject("Excel.Application")srcData.Visible = Trueset srcDoc = srcData.Workbooks.Open(pathway)srcDoc.Worksheets(sheetname).ActivatesrcDoc.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" + micCtrlUpDim WshShellSet WshShell=CreateObject("Wscript.Shell")WshShell.SendKeys "^s"wait(1)srcData.Workbooks.CloseSet srcDoc = nothingWindow("text:=Microsoft Excel").CloseEnd Function'定时停留弹出框函数Sub QTP_Msgbox(Value,waitTime,Title)Dim WshShellSet WshShell = CreateObject("WScript.Shell")WshShell.Popup Value, waitTime, TitleSet WshShell = nothingEnd Sub'改变Excel的单元格颜色Public Function QTP_Change_Color(pathway,sheetname,x,y,color) Dim srcData,srcDoc,sp1,sp2,num,use,a1,a2,a3set srcData = CreateObject("Excel.Application")srcData.Visible = Trueset srcDoc = srcData.Workbooks.Open(pathway)srcDoc.Worksheets(sheetname).ActivateIf color = "red" ThensrcDoc.Worksheets(sheetname).Cells(x,y).Interior.color=vbredElseIf color = "green" ThensrcDoc.Worksheets(sheetname).Cells(x,y).Interior.color=vbgreen ElseMsgBox "输入的颜色参数不正确，只接收""red""和""green"""End IfDim WshShellSet WshShell=CreateObject("Wscript.Shell")WshShell.SendKeys "^s"wait(1)srcData.Workbooks.CloseSet srcDoc = nothingWindow("text:=Microsoft Excel").CloseEnd Function'捕获当前屏幕（截图）Public Function QTP_Capture(pathway)Dim datestampDim filenamedatestamp = Now()filename = Environment("TestName")&"_"&datestamp&".png" filename = Replace(filename,"/","")filename = Replace(filename,":","")filename = pathway + "/" + ""&filenameDesktop.CaptureBitmap filename'Reporter.ReportEvent micFail,"image","<img src='" & filename & "'>"End Function''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''QuickTestPlus 帮助文件对于Excel库函数仅QTP适用'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim ExcelApp 'As Excel.ApplicationDim excelSheet 'As Excel.worksheetDim excelBook 'As Excel.workbookDim fso 'As Scripting.FileSystemObjectFunction CreateExcel() 'As Excel.ApplicationDim excelSheet 'As Excel.worksheetSet ExcelApp = CreateObject("Excel.Application") 'Create a new excel Object ExcelApp.Workbooks.AddExcelApp.Visible = TrueSet CreateExcel = ExcelAppEnd FunctionSub CloseExcel(ExcelApp)Set excelSheet = ExcelApp.ActiveSheetSet excelBook = ExcelApp.ActiveWorkbookSet fso = CreateObject("Scripting.FileSystemObject")On Error Resume Nextfso.CreateFolder "C:/Temp"fso.DeleteFile "C:/Temp/ExcelExamples.xls"excelBook.SaveAs "C:/Temp/ExcelExamples.xls"ExcelApp.QuitSet ExcelApp = NothingSet fso = NothingErr = 0On Error GoTo 0End SubFunction SaveWorkbook(ExcelApp, workbookIdentifier, path) 'As String Dim workbook 'As Excel.workbookOn Error Resume NextSet workbook = ExcelApp.Workbooks(workbookIdentifier)On Error GoTo 0If Not workbook Is Nothing ThenIf path = "" Or path = workbook.FullName Or path = Then workbook.SaveElseSet fso = CreateObject("Scripting.FileSystemObject")If InStr(path, ".") = 0 Thenpath = path & ".xls"End IfOn Error Resume Nextfso.DeleteFile pathSet fso = NothingErr = 0On Error GoTo 0workbook.SaveAs pathEnd IfSaveWorkbook = 1ElseSaveWorkbook = 0End IfEnd FunctionSub SetCellValue(excelSheet, row, column, value)On Error Resume NextexcelSheet.Cells(row, column) = valueOn Error GoTo 0End SubFunction GetCellValue(excelSheet, row, column)value = 0Err = 0On Error Resume NexttempValue = excelSheet.Cells(row, column)If Err = 0 Thenvalue = tempValueErr = 0End IfOn Error GoTo 0GetCellValue = valueEnd FunctionFunction GetSheet(ExcelApp, sheetIdentifier) 'As Excel.worksheet On Error Resume NextSet GetSheet = ExcelApp.Worksheets.Item(sheetIdentifier)On Error GoTo 0End FunctionFunction InsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName) 'As Excel.worksheetDim workbook 'As Excel.workbookDim worksheet 'As Excel.worksheet'In case that the workbookIdentifier is empty we will work on the active workbook If workbookIdentifier = "" ThenSet workbook = ExcelApp.ActiveWorkbookElseOn Error Resume NextErr = 0Set workbook = ExcelApp.Workbooks(workbookIdentifier)If Err <> 0 ThenSet InsertNewWorksheet = NothingErr = 0Exit FunctionEnd IfOn Error GoTo 0End IfsheetCount = workbook.Sheets.Countworkbook.Sheets.Add , sheetCountSet worksheet = workbook.Sheets(sheetCount + 1)If sheetName <> "" Then = sheetNameEnd IfSet InsertNewWorksheet = worksheetEnd FunctionFunction CreateNewWorkbook(ExcelApp)Set NewWorkbook = ExcelApp.Workbooks.Add()Set CreateNewWorkbook = NewWorkbookEnd FunctionFunction OpenWorkbook(ExcelApp, path)On Error Resume NextSet NewWorkbook = ExcelApp.Workbooks.Open(path)Set OpenWorkbook = NewWorkbookOn Error GoTo 0End FunctionSub ActivateWorkbook(ExcelApp, workbookIdentifier)On Error Resume NextExcelApp.Workbooks(workbookIdentifier).ActivateOn Error GoTo 0End SubSub CloseWorkbook(ExcelApp, workbookIdentifier)On Error Resume NextExcelApp.Workbooks(workbookIdentifier).CloseOn Error GoTo 0End SubFunction CompareSheets(sheet1, sheet2, startColumn, numberOfColumns, startRow, numberOfRows, trimed) 'As BooleanDim returnVal 'As BooleanreturnVal = TrueIf sheet1 Is Nothing Or sheet2 Is Nothing ThenCompareSheets = FalseExit FunctionEnd IfFor 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 ThenValue1 = Trim(Value1)Value2 = Trim(Value2)End IfIf Value1 <> Value2 ThenDim cell 'As Excel.Rangesheet2.Cells(r, c) = "Compare conflict - Value was '" & Value2 & "', Expected value is '" & Value1 & "'."Set cell = sheet2.Cells(r, c)cell.Font.Color = vbRedreturnVal = FalseEnd IfNextNextCompareSheets = returnValEnd Function'写入word文件Sub QTP_WriteWord(pathway,content)Dim oWord,oRange,oDocSet oWord = CreateObject("Word.Application")oWord.documents.open pathway,forwriting, TrueSet oDoc = oWord.ActiveDocumentSet oRange = oDoc.contentoRange.insertafter contentoWord.ActiveDocument.Save' Dim WshShell' Set WshShell=CreateObject("Wscript.Shell")' WshShell.SendKeys "^s"' wait(1)oWord.Application.Quit True Set oRange = NothingSet oDoc = NothingSet oWord = NothingEnd Sub。