''以下为QuickTest和Robot都适用函数'''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '获取当前日期 Public Function Get_Data() Dim currentDate currentDate = Date Get_Data = currentDate End Function '获取当前时间 Public Function Get_Time() Dim currentTime currentTime = Time Get_Time = currentTime End Function '随机函数生成 '输入值:生成值范围 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) Dim MyValue,i For i = 1 To RunTime Randomize MyValue = Int(((toNum - fromNum + 1) * Rnd) + (fromNum)) Next Get_randNum=MyValue End If End Function '值交换函数 Public Sub swap(byref a,byref b) Dim c c = a a = b b = c End Sub '是否是质数函数 '是质数返回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 '读指定文本文件指定行内容 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 '随机生成字符串 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 '启动资源管理器 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 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 '去掉字符串中的重复项 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 OPYear = temp(0) OPMonth = temp(1) OPDay = temp(2) flag = 0 If OPMonth = 1 Or OPMonth = 3 Or OPMonth = 5 Or OPMonth = 7 Or OPMonth = 8 Or OPMonth = 10 Or OPMonth = 12 Then If OPDay > 31 Or OPDay < 1 Then flag = 1 End If ElseIf OPMonth = 4 Or OPMonth = 6 Or OPMonth = 9 Or OPMonth = 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 OPMonth = 1 Or OPMonth = 3 Or OPMonth = 5 Or OPMonth = 7 Or OPMonth = 8 Or OPMonth = 10 Or OPMonth = 12 Then 'big month If OPDay = 31 Then OPDay = 1 If OPMonth = 12 Then OPMonth = 1 OPYear = OPYear + 1 Else OPMonth = OPMonth + 1 OPYear = OPYear End If Else OPDay = OPDay + 1 End If ElseIf OPMonth = 4 Or OPMonth = 6 Or OPMonth = 9 Or OPMonth = 11 Then 'small month If OPDay = 30 Then OPDay = 1 If OPMonth = 12 Then OPMonth = 1 OPYear = OPYear + 1 Else OPMonth = OPMonth + 1 OPYear = OPYear End If Else OPDay = OPDay + 1 End If Else 'February If ISLeapYear(OPYear) Then If OPDay = 29 Then OPDay = 1 If OPMonth = 12 Then OPMonth = 1 OPYear = OPYear + 1 Else OPMonth = OPMonth + 1 OPYear = OPYear End If Else OPDay = OPDay + 1 End If Else If OPDay = 28 Then OPDay = 1 If OPMonth = 12 Then OPMonth = 1 OPYear = OPYear + 1 Else OPMonth = OPMonth + 1 OPYear = OPYear End If Else OPDay = 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 objQTPWin = GetObject("" , "QuickTest.Application") objQTPWin.WindowState = "Minimized" Set objQTPWin = Nothing End Sub '恢复QTP窗口 Public Sub QTP_Big() Dim objQTPWin Set objQTPWin = GetObject("" , "QuickTest.Application") objQTPWin.WindowState = "Restored" Set objQTPWin = 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 & "" mce_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 OpenWorkbook = 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 oWord = CreateObject("Word.Application") oWord.documents.open pathway,forwriting, True Set oDoc = oWord.ActiveDocument Set oRange = 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 oRange = Nothing Set oDoc = Nothing Set oWord = Nothing End Sub 转载自::http://blog.csdn.net/daisyysiad/archive/2009/05/05/4152699.aspx