Codetie.com - Code details

Embed: Download

Theme:

Formatted as:

VBScript

New code

'查询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码值冒泡排序
'参数说明：待排序的字符串分隔符排序方式：
'1降序，2升序排序完的序列
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
'检查是否存在数字输入字符串 true：存在数字 false：不存在数字
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
'计算两个日期之间相隔几天
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
'删除指定的目录
'调用示例：DeleteAFolder("c:\log")
Sub DeleteAFolder(filespec)
On Error Resume Next
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder(filespec)
Set fso=Nothing
End Sub
'日志输出函数，包含三个参数
'参数1:tcfile,执行用例文件名称
'参数2:报告输出存放路径
'调用示例：call ExecuteTc("d:\share\Config.txt","c:\log")
Function ExecuteTc(tcfile,reportpath)
On Error Resume Next
Dim arrpaths,arrtcs,dicConfig
'初始化
Set dicConfig=CreateObject("Scripting.Dictionary")
Set fso=CreateObject("Scripting.FileSystemObject")
If fso.FileExists(tcfile) Then
Else
Exit Function
End If
'删除结果目录内容
fso.DeleteFolder(reportpath)
'读取配置文件内容，并将这些内容放到Dictionary中
Set f=fso.OpenTextFile(tcfile)
Do While(f.AtEndOfStream=false)
strline=f.ReadLine
If(Instr(strline,"=")> 1 ) Then
arr=Split(strline,"=")
configItem=LTrim(arr(0))
configItem=RTrim(configItem)
configValue=LTrim(arr(1))
configValue=RTrim(configValue)
dicConfig.Add configItem,configValue
End If
Loop
'将Dictionary中值和键分别放到数组中
arrpaths=dicConfig.items
arrtcs=dicConfig.keys
'循环读取用例，执行并将结果存放于指定目录
For i = 0 To dicConfig.Count -1
Dim qtApp
'杀进程
KillProc("IEXPLORE.EXE")
KillProc("QTPro.exe")
KillProc("QTAutomationAgent.exe")
Set qtApp = CreateObject("QuickTest.Application")
qtApp.Launch
qtApp.Visible =True
qtApp.Open arrpaths(i),True
Set qtTest=qtApp.test
Set qtResultsOpt = CreateObject("QuickTest.RunResultsOptions")
qtResultsOpt.ResultsLocation = reportpath & "\"&arrtcs(i)
qtTest.run qtResultsOpt
qtApp.quit
Set qtApp=Nothing
'杀进程
KillProc("IEXPLORE.EXE")
KillProc("QTPro.exe")
KillProc("QTAutomationAgent.exe")
Next
'释放资源
Set dicConfig=Nothing
Set fso=Nothing
Set f=Nothing
Set arrpaths= Nothing
Set arrtcs=Nothing
Set configvalue=Nothing
Set configitem=Nothing
Set arr=Nothing
Set strline=Nothing
End Function
'获取当前日期
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
'求字符串长度（中文算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 HighlightAll(TestObject)
Dim Parent, Desc, Props, PropsCount, MaxIndex, i, Objs
If IsEmpty(TestObject.GetTOProperty("parent")) Then
Set Parent = Desktop
Else
Set Parent = TestObject.GetTOProperty("parent")
End If
Set Desc = Description.Create
Set Props = TestObject.GetTOProperties
PropsCount = Props.Count - 1
For i = 0 to PropsCount
Desc(Props(i).Name).Value = Props(i).Value
Next
Set Objs = Parent.ChildObjects(Desc)
MaxIndex= Objs.Count - 1
For i = 0 to MaxIndex
Objs.Item(i).Highlight
Next
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 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 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
'杀死指定名称的进程
'调用示例：KillProc("Foxmail.exe")
Function KillProc(strProcName)
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set arrProcesses = objWMIService.ExecQuery( "select * from win32_process where Name ='"&strProcName&"'" )
For Each proccess In arrProcesses
proccess.Terminate 0
Next
End Function
'随机生成字符串
'调用示例：str=MakeString(10)
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
'去掉字符串中的重复项
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
'求下一天是几号的函数
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
Public Function OpenIE( byval dAddress)
SystemUtil.Run "iexplore.exe", dAddress
End Function
'让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
'写文件函数(追加)
'输入值：写入内容
'调用示例：call QTP_WriteFile("c:\1.txt","hello world")
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
'写文件函数(改写)
'输入值：写入内容
'调用示例：Call QTP_WriteFile_Change("c:\1.txt","hellosasasaasas world")
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文件元素
'调用示例：cellstr=QTP_Read_Excel("c:\mytest.xls","Data",4,2)　4为行,2为列
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文件元素并保存退出
'调用示例：QTP_Write_Excel("c:\mytest.xls","Data",4,2,"abcdef")　4为行,2为列
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
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
'定时停留弹出框函数
'调用示例：call QTP_Msgbox("业务处理错误",2,"调试提示")
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
'捕获当前屏幕（截图）
'调用示例：call QTP_Capture("c:\")
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",""
End Function
'日志输出函数，包含三个参数
'参数1:EventStatus包括 micPass，micFail，micDone，micWarning
'参数2:ReportStepName,主题名称
'参数3:Details，详细描述
'调用示例： rep micPass,"TC00001","http://news.sina.com.cn链接成功打开"
Public Function rep(EventStatus,ReportStepName,Details)
Reporter.Filter = rfEnableAll
Reporter.ReportEvent EventStatus,ReportStepName,Details
Reporter.Filter = rfDisableAll
End Function
'读指定文本文件指定行内容
'调用示例：str=ReadLine("c:\1.txt",4)
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
'启动运行
Sub Run()
Dim WshShell
set WshShell = CreateObject("Wscript.Shell")
WshShell.SendKeys "^{ESC}R"
Set WshShell = nothing
End Sub
'运行指定程序
Sub RunApp(command)
Dim WshShell
set WshShell = CreateObject("Wscript.Shell")
WshShell.Exec command
End Sub
'值交换函数
Public Sub swap(byref a,byref b)
Dim c
c = a
a = b
b = c
End Sub
'发送电子邮件
'调用示例：call SendMail("yong_yu@jit.com.cn","自动化测试试验","自动化测试报告","c:\autotestreport.html")
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
'启动资源管理器
Sub ZYGLQ()
Dim WshShell
set WshShell = CreateObject("Wscript.Shell")
WshShell.SendKeys "^+{ESC}"
Set WshShell = nothing
End Sub