'''以下为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 & "'>"
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
扫一扫
3825
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
