'**************************************************************************
*****************************************************
'有用的没用的都丢到一起，可能会有你想要的，原本是分为FileOper、DataOper、We
bOper（基于SAFFRON）、Win32Oper和ErrorOper五个文件
'后面三个超级啰嗦超级长的废物可能别人用不到，不过构造思路比较清晰，大家可以
DIY一下，或许你会觉得很方便，至少可以不用CheckPoint
'**************************************************************************
*****************************************************
classArray = Split("Browser,Page,Frame",",")
descArray = Split("micclass:=Browser,micclass:=Page,micclass:=Frame,",",")
objectArray = Split("Link,WebButton,WebList,WebEdit,Image", ",")
objectDescArray =
Split("micclass:=Link,micclass:=WebButton,micclass:=WebList,micclass:=WebEd
it,micclass:=Image", ",")
'**************************************************************************
*****************************************************
'设计说明：关闭所有打开的IE
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：CloseBrowsers
'**************************************************************************
*****************************************************
Public Sub CloseAllBrowser
Set Wshshell = CreateObject("Wscript.Shell")
Set DialogObject = Description.Create()
DialogObject("micclass").Value = "Dialog"
Set Windows32Dialog = Desktop.ChildObjects(DialogObject)
dlNum = Windows32Dialog.Count - 1
For v = 0 to dlNum
Windows32Dialog(v).Close
Next
Set Windows32Dialog = Nothing
Set theBrowser = Browser("micclass:=Browser", "index:=0")
While theBrowser.Exist(0)
theBrowser.Close
'有些系统页面可能在关闭的时候会有提示对话框出现
waitNx = 1
Do While waitNx < 5
Set Windows32Dialog = Desktop.ChildObjects(DialogObject)
dlNum = Windows32Dialog.Count - 1
For v = 0 to dlNum
dlText = Windows32Dialog(v).GetROProperty("regexpwndtitle")
Wshshell.AppActivate(dlText)
Wait(1)
Wshshell.SendKeys "{ENTER}"
Next
Set Windows32Dialog = Nothing
waitNx = waitNx + 1
Loop
Report
Pass,"使用CloseAllOpenedBrowsers函数页面关闭成功","当前页面关闭成功！"
Wend
Set theBrowser = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：最大化IE浏览器
'程序输入：无
'程序输出：无
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：MaximizeBrowser
'**************************************************************************
*****************************************************
Sub MaximizeBrowser
Set BrowserObject = Description.Create()
BrowserObject("NativeClass").Value = "IEFrame"
Set WindowsBrowser = Desktop.ChildObjects(BrowserObject)
brNum = WindowsBrowser.Count - 1
For i = 0 To brNum
ieVersion = WindowsBrowser(i).GetROProperty("version")
wndTitle = WindowsBrowser(i).GetROProperty("title")
Set ObjectBrowser = Browser("micclass:=Browser", "index:="&i)
If Instr(ieVersion,6) > 0 Then
Window("regexpwndclass:=IEFrame","index:=0","text:="&wndTitle&".*").M
aximize
Else
WindowsBrowser(i).Maximize
End If
Set ObjectBrowser = Nothing
Next
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：根据对象属性列表和属性值列表匹配Browser对象，该函数基本无用… …
'程序输入：对象属性列表和属性值列表，列表使用英文半角的逗号分隔
'程序输出：创建对象
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：GenerateBrowserObject("name,title","保险业务管理系统,保险业务管
理系统")
'**************************************************************************
*****************************************************
Public Function GenerateBrowser(p_Attlist,p_Keylist)
AttArray = Split(p_Attlist,",")
KeyArray = Split(p_Keylist,",")
exeStr = "Browser("
If UBound(AttArray) <> UBound(KeyArray) Then
Report
Fail,"使用GenerateBrowserObject函数参数输入错误","对象属性的个数应该与
其对应的属性值个数相等！"
Exit Function
End If
For inx = 0 to UBound(AttArray)
exeStr =
exeStr&Chr(34)&AttArray(inx)&":=.*"&KeyArray(inx)&".*"&Chr(34)&","
Next
Execute "Set MyObject = "&exeStr&Quote("index:=0")&")"
If MyObject.Exist(0) Then
Report
Pass,"使用GenerateBrowserObject函数构造对象成功","按照Browser对象属性列
表【"&p_Attlist&"】，属性值列表【"&p_Keylist&"】，生成Browser对象成功！
"
Else
Report
Fail,"使用GenerateBrowserObject函数构造对象失败","按照Browser对象按照属
性列表【"&p_Attlist&"】，属性值列表【"&p_Keylist&"】，匹配Browser对象失
败！"
ExitRun
End If
Set GenerateBrowser = MyObject
End Function
'**************************************************************************
*****************************************************
'设计说明：初始化所有打开的Browser页面，不厌设计复杂只为稳定高效
'程序输入：无
'程序输出：初始化成功或者失败
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：BrowserSync
'**************************************************************************
*****************************************************
Public Function SyncronizeBrowser()
Set MyBrowser = Browser("micclass:=Browser", "index:=0")
If MyBrowser.Exist(0) Then
MyBrowser.Sync
Do Until MyBrowser.GetROProperty("url") <> "" And
MyBrowser.GetROProperty("name") <> ""
Delay 50
Loop
Else
Set MyBrowser = Nothing
SyncronizeBrowser = False
Report Warning ,"初始化页面失败","页面初始化失败，需要重新操作！"
Exit Function
End If
Set MyBrowser = Nothing
SyncronizeBrowser = True
End Function
'**************************************************************************
*****************************************************
'设计说明：打开指定的地址，并且初始化页面，特别说明：对于地址栏出现一次性se
ssionid的网页不可用该函数
'程序输入：url地址
'程序输出：初始化成功或者失败
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：print SyncronizeSepecifiedURL("www.baidu.com")
'**************************************************************************
*****************************************************
Public Function NavigateBrowser(para_myuri)
CloseAllBrowser
Set IEBrowser = CreateObject("InternetExplorer.Application")
IEBrowser.Visible = True
IEBrowser.Navigate para_myuri
Set ObjectBrowser = Browser("micclass:=Browser", "index:=0")
Do Until SyncronizeBrowser() = True
Wait(1)
Loop
actualurl = ObjectBrowser.GetROProperty("url")
'下面这个判断主要是为了解决初始化地址跳转问题，如果URL发生变化会导致对象
属性发生变化从而导致运行错误。
If actualurl <> para_myuri Then
ObjectBrowser.Close
Set IEBrowser = Nothing
Set IEBrowser = CreateObject("InternetExplorer.Application")
IEBrowser.Visible = True
IEBrowser.Navigate actualurl
If Not SyncronizeBrowser() Then
Report
Warning,"使用NavigateBrowser函数IE初始化失败","打开指定页面【"&myuri&
"】在初始化的时候失败！"
Set MyBrowser = Nothing
Set IEBrowser = Nothing
Exit Function
End If
End If
Set ObjectBrowser = Nothing
Set IEBrowser = Nothing
Report
Pass,"使用NavigateBrowser函数IE初始化成功","打开指定页面【"¶_myuri&"
】并且初始化成功！"
NavigateBrowser = True
End Function
'**************************************************************************
*****************************************************
'设计说明：处理弹出对话框，主要用于弹出的可预知性能够得到控制的地方，未知弹
出需引用其他函数处理
'程序输入：选择对话框操作：是/否/确认/取消/确定等等，是否需要向结果中添加提
示信息的报告
'程序输出：结果报告
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：HandleDialog "确认","Y"
'**************************************************************************
*****************************************************
Public Function HandleDialog(regexpName,needAlertInfo)
If Trim(regexpName) = "" Then
regexpName = "无需匹配的按钮！"
End If
Set Wshshell = CreateObject("Wscript.Shell")
Set DialogObject = Description.Create()
DialogObject("micclass").Value = "Dialog"
Set WindowsDialog = Desktop.ChildObjects(DialogObject)
dlNum = WindowsDialog.Count - 1
If dlNum < 0 Then
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Report micDone,"没有任何弹出框","不需要进行对话框的处理！"
Exit Function
End If
For inx = 0 to dlNum
If needAlertInfo = "Y" Or needAlertInfo = True Then
Set StaticObject = Description.Create()
StaticObject("micclass").Value = "Static"
Set WindowsStatic = WindowsDialog(inx).ChildObjects(StaticObject)
stNum = WindowsStatic.Count
disMessage = WindowsStatic(stNum - 1).GetROProperty("text")
Report micDone,"获取网页对话框信息成功：",disMessage
Set WindowsStatic = Nothing
Set StaticObject = Nothing
End If
dialogTitle = WindowsDialog(inx).GetROProperty("text")
Set WinButtonObject = Description.Create()
WinButtonObject("micclass").Value = "WinButton"
Set WindowsButton = WindowsDialog(inx).ChildObjects(WinButtonObject)
wbNum = WindowsButton.Count - 1
For binx = 0 to wbNum
btName = WindowsButton(binx).GetROProperty("text")
If Instr(btName,regexpName) > 0 Then
WindowsButton(binx).Click
Report
Pass,"函数HandleDialog点击指定按钮成功","按照指定的按钮名称【"®e
xpName&"】查找并点击按钮成功！"
Exit For
End If
If binx = wbNum And Instr(btName,regexpName) = 0 Then
Wshshell.AppActivate(dialogTitle)
Wait(0)
Wshshell.SendKeys "{ENTER}"
Report
micWarning,"函数HandleDialog点击按钮","没有匹配到指定按钮，对已经弹
出的对话框直接使用默认操作！"
End If
Next
Set WindowsButton = Nothing
Set WinButtonObject = Nothing
Next
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：SAFFRON框架引用以及部分改造，函数分流之后的部分
'程序输入：参见各个函数
'程序输出：
'设计人员：
'设计时间：2011-01-08
'调用举例：
'**************************************************************************
*****************************************************
Public Function GenerateDescription (classString,isModleWindow)
classNx = IndexOf(classArray, classString)
If classNx >= 0 Then
'增加对模态窗口的支持
If isModleWindow = "Y" Or isModleWindow = True Then
descString = "Window("&Quote("nativeclass:=Internet
Explorer_TridentDlgFrame")&")."
Else
descString = classArray(0)&"("&Quote(descArray(0))&")."
End If
If classNx >= 1 Then
descString = descString + classArray(1)&"("&Quote(descArray(1))&")."
If 2 >= classNx Then
If hasFrameValue <> "" Then
descString = descString +
classArray(2)&"("&Quote(descArray(2))&","&Quote("name:="&hasFrame
Value)&")."
End If
End If
End If
End If
GenerateDescription = descString
End Function
'**************************************************************************
**********************************************
Public Function GenerateObjectDescription (objClassName, otherAtt)
objNx = IndexOf(objectArray, objClassName)
objNameString = ""
If objNx <> -1 Then
objNameString =
objClassName&"("&Quote(objectDescArray(objNx))&","&Quote(otherAtt)&","&
Quote("index:=0")&")."
End If
GenerateobjectDescription = objNameString
End Function
'**************************************************************************
**********************************************
Public Function ObjectWorkUnderFrame(frameName)
hasFrameValue = frameName
End Function
'**************************************************************************
**********************************************
Public Function ObjectNotWorkUnderFrame()
hasFrameValue = ""
End Function
'**************************************************************************
**********************************************
Public Function VerifyObject (objectClassName, text,isModleWindow)
rval = false
localDesc = ""
estr = ""
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
Select Case objectClassName
Case "Page"
Execute "rval =
"&GenerateDescription(classArray(1),isModleWindow)&"Exist (0)"
If rval Then
Execute "title =
"&GenerateDescription(classArray(1),isModleWindow)&"GetROProperty("
&Quote("title")&")"
If title = text Then
rval = true
Else
rval = false
End If
End If
Case "CurrentFrame"
If hasFrameValue <> "" Then
estr = "rval = "&localDesc
End If
Case "Link"
estr = "rval = "&localDesc&GenerateObjectDescription("Link",
"innertext:=.*"&text&".*")
Case "WebButton"
estr = "rval = "&localDesc&GenerateObjectDescription("WebButton",
"value:=.*"&text&".*")
Case "WebList"
estr = "rval = "&localDesc&GenerateObjectDescription("WebList",
"name:=.*"&text&".*")
Case "WebEdit"
estr = "rval = "&localDesc&GenerateObjectDescription("WebEdit",
"name:=.*"&text&".*")
End Select
If estr <> "" Then
Execute estr + "Exist (0)"
End If
If rval Then
Report micDone, objectClassName&"匹配对象成功",
"对象【"&objectClassName&"】【 "&Quote(text)&" 】查询成功！"
VerifyObject = True
Else
Report Warning, objectClassName&"匹配对象失败",
"对象【"&objectClassName&"】【 "&Quote(text)&" 】查询无果！"
VerifyObject = False
End If
End Function
'**************************************************************************
**********************************************
Public Function ClickSpecifiedObject (objectClassName, text, isModleWindow)
localDesc = ""
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
Select Case objectClassName
Case "Link"
Execute
localDesc&GenerateObjectDescription("Link","innertext:=.*"&text&".*")
&"Click"
SyncronizeBrowser
Report micDone,
"链接点击完成：","链接【"&text&"】点击完毕，并且已经执行网页初始化！"
Case "WebButton"
Execute localDesc&GenerateObjectDescription("WebButton",
"value:=.*"&text&".*")&"Click"
SyncronizeBrowser
Report micDone, "按钮点击完成：",
"按钮【"&text&"】点击完毕，并且已经执行网页初始化！"
Case "Image"
Execute localDesc&GenerateObjectDescription("Image",
"alt:=.*"&text&".*")&"Click"
SyncronizeBrowser
Report micDone, "图标点击完成：",
"图标【"&text&"】点击完毕，并且已经执行网页初始化！"
End Select
End Function
'**************************************************************************
**********************************************
Public Function SelectFromList (objectName, text, isModleWindow)
localDesc = ""
rv = ""
rval = false
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
localDesc = localdesc&GenerateObjectDescription("WebList",
"name:=.*"&objectName&".*")
Execute "cnt = "&localDesc&"GetROProperty("&Quote("items count")&")"
For i = 1 to cnt
Execute "rv = "&localDesc&"GetItem ("&i&")"
If rv = text Then
rval = true
End If
Next
If rval Then
Execute localDesc&"Select "&Quote(text)
SyncronizeBrowser
Report micDone, "下拉列表选择成功",
"选择项【"&text&"】已经被查询到、选择，并且执行初始化！"
Else
Report micFail, "下拉列表选择失败",
"选择项【"&text&"】没有在下拉列表【"&objectName&"】中查询到查询到！"
Exit Function
End If
SelectFromList = True
End Function
'**************************************************************************
**********************************************
Public Function EnterValueForEdit (objectName, text,isModleWindow)
localDesc = ""
rval = true
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
localDesc = localdesc&GenerateObjectDescription("WebEdit",
"name:=.*"&objectName&".*")
Execute localDesc&"Set ("&Quote(text)&")"
Report micDone, "文本框输入操作：",
"文本【"&text&"】成功输入到输入框【"&objectName&"】!"
EnterValueForEdit = rval
End Function
'**************************************************************************
*****************************************************
'设计说明：从数据库中抓取指定表和列的数据，依赖ORAOLEDB组件的正常使用，不用
创建数据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 要抓取的字段
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：要抓取的字段
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：MsgBox FetchDBDataOle("select * from
plan","plan_code","A","10.31.10.105","1555","B","C")
'**************************************************************************
*****************************************************
Public Function
FetchDBData(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,sqlText,
tableColumn)
Set DBRec=createobject("adodb.recordset")
Set DBCon=createobject("adodb.Connection")
DBCon.ConnectionString="Provider=""OraOLEDB.Oracle"";User ID="&_
DBUserName &";Data Source=""(description =(address = (protocol =
tcp)(host = "&_
DBHostAddress &")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBCon.Open
DBRec.Open sqlText,DBCon
FetchDBData = DBRec.Fields(tableColumn)
DBCon.Close
Set DBRec = Nothing
Set DBCon = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：从数据库中抓取指定表和列的数据，基于MSDAORA对象的使用，不依赖ORA
OLEDB，不用创建数据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 要抓取的字段
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：要抓取的字段
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：MsgBox FetchDBData("select * from
plan","plan_code","A","10.31.10.105","1555","B","C")
'**************************************************************************
*****************************************************
Public Function
FetchDBDataMSDAORA(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,s
qlText,tableColumn)
Set DBCon = CreateObject("ADODB.Connection")
Set DBRec = CreateObject("ADODB.RecordSet")
DBCon.Open = "Provider=""MSDAORA.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress &")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBRec.OPEN sqlText,DBCon
FetchDBDataMSDAORA = DBRec.fields(tableColumn)
DBCon.close
Set DBCon =Nothing
Set DBRec = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：按照传入SQL修改数据库的值，依赖ORAOLEDB组件的正常使用，不用创建
数据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：无
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：Call ModifyDBDataOle("A","10.31.10.105","1555","B","C"，"update
Test set Col = 'A' where Col = 'B'")
'**************************************************************************
*****************************************************
Public Sub
ModifyDBData(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,sqlText
)
Set DBRec=createobject("adodb.recordset")
Set DBCom=createobject("adodb.command")
DBCom.activeconnection="Provider=""OraOLEDB.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress&")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBCom.CommandType = 1
DBCom.CommandText = sqlText
Set DBRec = DBCom.Execute()
DBCom.CommandText = "commit"
Set DBRec = DBCom.Execute()
Set DBRec = Nothing
Set DBCom = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：按照传入SQL修改数据库的值，不依赖ORAOLEDB组件的使用，不用创建数
据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：无
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：Call ModifyDBData("A","10.31.10.105","1555","B","C"，"update
Test set Col = 'A' where Col = 'B'")
'**************************************************************************
*****************************************************
Public Sub
ModifyDBDataMSDAORA(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,
sqlText)
Set DBCon = CreateObject("ADODB.Connection")
Set DBRec = CreateObject("ADODB.RecordSet")
DBCon.Open = "Provider=""MSDAORA.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress &")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBRec.OPEN sqlText,DBCon
DBRec.OPEN "commit",DBCon
DBCon.Close
Set DBCon =Nothing
Set DBRec = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：调用存储过程，不依赖ORAOLEDB组件的使用，不用创建数据源，不用配置
连接串
'程序输入：
' 要执行的存储过程名
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：无
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：Call
RunProcedure("gbsjob.job_package.gbs_job4","pub_test","10.31.9.62","1562","
gs30gbs","test2012")
'**************************************************************************
*****************************************************
Sub
RunProcedure(procName,DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWor
d)
Set DBCon = CreateObject("ADODB.Connection")
Set DBRec = CreateObject("ADODB.RecordSet")
Set DBcom = CreateObject("ADODB.Command")
DBCon.Open = "Provider=""MSDAORA.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress&")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBcom.ActiveConnection = DBCon
DBcom.CommandType = 4
DBcom.CommandText = procName
DBcom.Execute
DBcom.CommandText = "commit"
DBcom.Execute
DBCon.close
Set DBcom = Nothing
Set DBCon =Nothing
Set DBRec = Nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：用于将EXCEL中某个SHEET单独COPY出来到一个临时的文件中，从临时文件
导入DATATABLE，避免SHEET过多导致的EXCEL出错
'程序输入：
' originalDataFile： 原EXCEL
' tempFileForImpt： 新的临时文件
' oldSheet： 原EXCEL的SHEET
' newSheet： 新的EXCEL临时SHEET
'程序输出：将指定路径下的指定EXCEL的指定SHEET导入DataTable
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例：Call impXls("D:\test.xls","D:\temp.xls","原始SHEET","新的SHEET")
'**************************************************************************
********************************************************************
Public Sub impXls(originalDataFile,tempFileForImpt,oldSheet,newSheet)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Application.Visible = False
If (Fso.FileExists(originalDataFile) = False) Then
Reporter.ReportEvent micFail,"参数文件不存在：",originalDataFile
Print "参数文件不存在："&originalDataFile
Set newBook = Nothing
ExcelApp.Quit
Set ExcelApp = Nothing
Set Fso = Nothing
Exit Sub
End If
Set newBook = ExcelApp.Workbooks.Open (originalDataFile,False,True)
newBook.Worksheets(oldSheet).copy
Set tempBook=ExcelApp.ActiveWorkbook
If (Fso.FileExists(tempFileForImpt) = True) Then
Set tempxls = Fso.GetFile(tempFileForImpt)
tempxls.Delete
tempBook.SaveAs tempFileForImpt
Set tempxls = Nothing
Else
tempBook.SaveAs tempFileForImpt
End If
Set tempBook = Nothing
ExcelApp.Quit
Set ExcelApp = Nothing
DataTable.AddSheet newSheet
DataTable.ImportSheet tempFileForImpt,oldSheet,newSheet
If (Fso.FileExists(tempFileForImpt) = True) Then
Set tempFile = fso.GetFile(tempFileForImpt)
tempFile.Delete
Set tempFile = Nothing
End If
Set Fso = Nothing
Reporter.ReportEvent
micPass,"导入参数文件成功：","文件：【"&originalDataFile&"】，SHEET页：【
"&newSheet&"】"
End Sub
'**************************************************************************
********************************************************************
'设计说明：写指定行和列的EXCEL的值
'程序输入：
' sheet： 写入的SHEET；
' row： 指定行；
' col： 指定的行；
' value： 写入值；
' pathAndFile： 文件路径
'程序输出：写入指定单元格，无需返回
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call WExcel("指定页",3,4,date,"D:\test.xls")
'**************************************************************************
********************************************************************
Public Sub WExcel(sheet,row,col,value,pathAndFile)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
If Fso.FileExists(pathAndFile) = True Then
Set newBook = ExcelApp.Workbooks.Open(pathAndFile)
newBook.Worksheets(sheet).Activate
newBook.Worksheets(sheet).Cells(row,col).value=value
newBook.Save
ExcelApp.Application.Quit
Else
Set newBook = ExcelApp.Workbooks.Add
newBook.Worksheets(sheet).Activate
newBook.Worksheets(sheet).Cells(row,col).value=value
newBook.SaveAs pathAndFile
ExcelApp.Application.Quit
End If
Set newBook = Nothing
Set ExcelApp = Nothing
Set Fso = Nothing
Set Wshshell = Nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：读指定行和列的EXCEL的值
'程序输入：
' sheet： 读取的SHEET；
' row： 指定行；
' col： 指定的行；
' pathAndFile： 文件路径
'程序输出：读取的指定单元格的值
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Msgbox getCellValue("指定页",3,4,"D:\test.xls")
'**************************************************************************
********************************************************************
Public Function getCellValue(sheet, row, column, pathAndFile)
Set Wshshell = CreateObject("Wscript.shell")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ExcelApp = CreateObject("excel.Application")
ExcelApp.Visible = False
If Fso.FileExists(pathAndFile) = True Then
Set newBook = ExcelApp.Workbooks.Open(pathAndFile,False,True)
Set excelSheet = newBook.Worksheets(sheet)
excelSheet.Activate
GetCellValue = excelSheet.Cells(row, column)
Set excelSheet = Nothing
Else
Reporter.ReportEvent
micFail,"未找到文件","指定文件：【"&originalDataFile&"】未找到，请确认
文件路径！"
Print "指定文件：【"&originalDataFile&"】未找到，请确认文件路径！"
End If
ExcelApp.Quit
Set ExcelApp = Nothing
Set Fso = Nothing
Set Wshshell = Nothing
End Function
'**************************************************************************
********************************************************************
'设计说明：读取以IE打开的EXCEL指定行和列的值
'程序输入：
' row： 指定行；
' col： 指定的行；
' url： IE地址url，一般可使用正则表达式来识别;
' tit： 网页标题
'程序输出：读取的指定单元格的值
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Msgbox
ieXlsValue(3,4,"http://ehis-nbs-stg.paic.com.cn/ehis/.*","^.*健康险.*")
'**************************************************************************
********************************************************************
Public Function ieXlsValue(row, column, url,tit)
on error resume Next
Set Wshshell = CreateObject("Wscript.shell")
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.navigate url
If Browser("title:="&tit).Exist(2) Then
Browser("title:="&tit).WinButton("Name:=打 开").Click
End If
For v = 1 To 5
If Dialog("Name:=Microsoft Excel").Exist(1) Then
Dialog("Name:=Microsoft Excel").WinButton("Name:=确定").Click
End If
Next
Set ExcelApp = Getobject(0,"excel.Application")
If Err = 0 Then
Set excelSheet = ExcelApp.ActiveSheet
excelSheet.Activate
GetCellValue = excelSheet.Cells(row, column)
Set excelSheet = Nothing
Else
Print "文件不存在！请确认IE中已经打开EXCEL页！"
End If
ExcelApp.Quit
Set ExcelApp = Nothing
Set Wshshell = Nothing
Set IE = Nothing
End Function
'**************************************************************************
********************************************************************
'设计说明：写入纯文本TXT文件
'程序输入：
' filepath： 文件路径和文件名组合；
' text： 写入值
'程序输出：写入txt，无需返回值
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call txtWrite("D:\test.txt","写入什么值")
'**************************************************************************
********************************************************************
Public Sub txtWrite(filepath,text)
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(filepath, True)
MyFile.Write(text)
MyFile.Close
Set MyFile = nothing
Set fso = nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：读取整个txt文本文件的值
'程序输入：filepath：txt文本文件所在路径和文件名的组合
'程序输出：整个TXT文件的内容。
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Msgbox txtRead("D:\text.txt")
'**************************************************************************
********************************************************************
Public Function txtReadAll(rfilepath)
Const ForReading = 1, ForWriting = 2
Dim fso, MyFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.OpenTextFile(rfilepath, ForReading)
txtRead = MyFile.readAll
Set MyFile = nothing
Set fso = nothing
End Function
'**************************************************************************
********************************************************************
'设计说明：从磁盘上删除指定txt文本文件
'程序输入：filepath：txt文本文件所在路径和文件名的组合
'程序输出：删除操作过程，无需返回
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call txtDelete("D:\text.txt")
'**************************************************************************
********************************************************************
Public Sub txtDelete(filepath)
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(filepath)
Set fso = Nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：指定上载文件中特定字符后指定长度的字符使用另一指定字符替换，逐行
处理、直至结束（剔除首行）
'程序输入：
' FilePath： 文件路径
' FileName： 文件名称
' SpecifiedStrMark： 指定字符
' replaceLength： 替换长度
' ReplaceWith： 用来替换的串
'程序输出：删除操作过程，无需返回
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call
ReplaceStr(FilePath,FileName,SpecifiedStrMark,replaceLength,ReplaceWith)
'**************************************************************************
********************************************************************
Public Sub
ReplaceStr(FilePath,FileName,SpecifiedStrMark,replaceLength,ReplaceWith)
If len(ReplaceWith) <> Abs(replaceLength) Then
Reporter.ReportEvent
micFail,"参数使用错误","请确认需要替换的长度与新的替换字符串长度一致！"
Print "参数使用错误:ReplaceWith参数长度要与replaceLength值一致！"
Exit Sub
End If
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set Fso = CreateObject("Scripting.FileSystemObject")
If Not Fso.FileExists(FilePath&FileName) Then
Reporter.ReportEvent
micFail,"参数使用错误","请确认指定的文件是否存在！"
Print
"参数使用错误:"&FilePath&FileName&"，请确认该指定的文件是否存在！"
Exit Sub
End If
Set MyOldFile = fso.OpenTextFile(FilePath&FileName, ForReading)
If Fso.FileExists(FilePath&"temp.txt") Then
Fso.DeleteFile(FilePath&"temp.txt")
End If
Set tmpFile = Fso.CreateTextFile(FilePath&"temp.txt",True)
v = 1
While Not MyOldFile.AtEndOfStream
orgStr = MyOldFile.readLine
If v > 1 Then
If instr(orgStr,SpecifiedStrMark) > 0 Then
timeMark =
Mid(orgStr,instr(orgStr,SpecifiedStrMark)+len(SpecifiedStrMark),r
eplaceLength)
newStr = Replace(orgStr,timeMark,ReplaceWith)
tmpFile.WriteLine(newStr)
Else
tmpFile.WriteLine(orgStr)
End If
Else
tmpFile.WriteLine(orgStr)
End If
v = v + 1
Wend
tmpFile.Close
MyOldFile.Close
Set tmpFile = Nothing
Set MyOldFile = Nothing
Set MyNewFile = Fso.OpenTextFile(FilePath&FileName, ForWriting)
Set MyTemFile = Fso.OpenTextFile(FilePath&"temp.txt", ForReading)
transStr = MyTemFile.ReadAll
MyNewFile.Write (transStr)
MyNewFile.Close
MyTemFile.Close
Fso.DeleteFile(FilePath&"temp.txt")
Set MyTemFile = Nothing
Set MyNewFile = Nothing
Set Fso = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：低级算法加密：密码明文加密，ASCII加随机整数拼装，如有需要可直接
写入TXT或EXCEL文件中去。
'程序输入：密码明文
'程序输出：加密字符串
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例：msgbox to_num("aaaaa888")
'**************************************************************************
*****************************************************
Public Function to_num(password)
Set Wshshell = Createobject("wscript.shell")
n = len(password)
i = 1
str = ""
Do while i <= n
If len(asc(mid(password,i,1))) = 1 Then
tran = "00"&asc(mid(password,i,1))
Elseif len(asc(mid(password,i,1))) = 2 Then
tran = "0"&asc(mid(password,i,1))
Else
tran = asc(mid(password,i,1))
End If
rank1 = Int(8*Rnd+1)
rank2 = Int(25*Rnd + 65)
char = (rank1-1)&chr(rank2)&rank1&chr(rank2+1)&(rank1+1)
str = str&tran&char
i = i + 1
Loop
to_num = str
End Function
'**************************************************************************
*****************************************************
'设计说明：如上to_num加密函数的对应解密函数
'程序输入：str：密文字符串
'程序输出：原始密码明文
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例：msgbox
openText("0975N6O70974H5I60972T3U40970T1U20976R7S80560K1L20566T7U80562Y3Z4"
)'
**************************************************************************
*****************************************************
Public Function openText(str)
n = len(str)/8
res = ""
Do
n = len(str)/8
char = chr(mid(str,1,3))
str = right(str,8*n-8)
res = res&char
If n = 1 Then
Exit Do
End If
Loop
openText = res
End Function
'**************************************************************************
************************************************************
'设计说明：查找指定进程
'程序输入：进程名称，如EXCEL.EXE
'程序输出：成功或者失败True/False
'设计人员：LIUYI027/PAICDOM
'设计时间：2010-01-05
'调用举例：Msgbox GetProcess("EXCEL")或msgbox GetProcess("EXCEL.EXE")
'**************************************************************************
************************************************************
Public Sub GetProcess(prcessName)
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set Processes = objWMIService.ExecQuery("select * from Win32_Process")
For Each Process In Processes
If InStr(UCase(Process.Name),UCase(prcessName)) > 0 Then
GetProcess = True
Else
GetProcess = False
End If
Next
Set Process = Nothing
Set objWMIService = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：用于将进程强行关闭，常用语EXCEL进程处理
'程序输入：进程名称，如EXCEL.EXE
'程序输出：关闭对应的进程
'设计人员：LIUYI027/PAICDOM
'设计时间：2010-01-05
'调用举例：Call KillProcess("EXCEL")或Call KillProcess("EXCEL.EXE")
'**************************************************************************
************************************************************
Public Sub KillProcess(prcessName)
If Len(prcessName) < 3 Then
Report
Warning,"使用函数KillProcess输入进程名称过短","过短的进程名称可能会匹配
到多个进程，操作将非常危险，请停止操作！"
Exit Sub
End If
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set Processes = objWMIService.ExecQuery("select * from Win32_Process")
For Each Process In Processes
If InStr(UCase(Process.Name),UCase(prcessName)) > 0 Then
SystemUtil.CloseProcessByName(Process.Name)
Report
Done,"系统出现"&UCase(prcessName)&"进程异常","该进程已经使用函数KillP
rocess强行关闭！"
End If
Next
Set Process = Nothing
Set objWMIService = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：解决快速运行中低于1秒的等待
'程序输入：循环次数，每次循环大约11.6毫秒
'程序输出：无
'设计人员：LIUYI027
'设计时间：2010-12-13
'调用举例：Delay 1000大约等待8秒，Delay 100大约等待1.157秒
'**************************************************************************
************************************************************
Public Sub Delay(i)
For x = 0 to i
a = x
Next
End Sub
'**************************************************************************
************************************************************
'设计说明：修改IE8的注册信息以便于运行
'程序输入：无
'程序输出：无
'设计人员：LIUYI027
'设计时间：2010-12-31
'调用举例：Call ModIERegForAutoMation()
'**************************************************************************
************************************************************
Public Sub ModIERegForAutomation
Set objShell = CreateObject("WScript.Shell")
'显示菜单栏
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\Main\AlwaysShowMenus",1,"REG_DWORD"
'显示收藏夹栏
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\LinksBar\Enabled",1,"REG_DWORD"
'菜单栏置顶
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\Toolbar\WebBrowser\ITBar7Position",1,"REG_DWORD"
'遇到弹出窗口时始终在新选项卡中打开弹出窗口
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\TabbedBrowsing\PopupsUseNewWindow",1,"REG_DWORD"
'其他程序从当前窗口的新选项卡打开连接
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\TabbedBrowsing\ShortcutBehavior",0,"REG_DWORD"
Set objShell = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：获取IP/域名ping的结果信息
'程序输入：被ping的IP或者域名
'程序输出：True成功、False失败
'设计人员：LIUYI027
'设计时间：2011-12-13
'调用举例：Call GetPingResult("www.google.com")
'**************************************************************************
************************************************************
Function GetPingResult(pingedHost)
Set oPing = GetObject("winmgmts:").ExecQuery ("select * from
Win32_PingStatus where address = '" & pingedHost & "'")
For Each oRetStatus In oPing
If ISNULL(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
GetPingResult = False
Else
GetPingResult = True
End If
Next
Set oPing = Nothing
End Function
'**************************************************************************
************************************************************
'设计说明：使用邮件服务器发送邮件
'程序输入：参见函数定义，非常用函数，不做赘述
'程序输出：发出邮件
'设计人员：LIUYI027
'设计时间：2010-12-13
'调用举例：Call
SendMail(mailFrom,mailSmtp,sendUserName,sendUserPassword,mailTo,mailSubject
,mailBody,mailAttachment)
'**************************************************************************
************************************************************
Function
SendMail(mailFrom,mailSmtp,sendUserName,sendUserPassword,mailTo,mailSubject
,mailBody,mailAttachment)
Const conSendUsing
="http://schemas.microsoft.com/cdo/configuration/sendusing"
Const conServer
="http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const conServerPort
="http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const conConnectionTimeout
="http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
Const conAuthenticate
="http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Const conUsessl
="http://schemas.microsoft.com/cdo/configuration/smtpusessl"
Const conSendUserName
="http://schemas.microsoft.com/cdo/configuration/sendusername"
Const conSendPassword
="http://schemas.microsoft.com/cdo/configuration/sendpassword"
Const conPickupPackage
="http://schemas.microsoft.com/cdo/configuration/smtpserverpickupdirector
y"
Set objMessage = CreateObject("CDO.Message")
Set objConfig = CreateObject("CDO.Configuration")
Set Fields = objConfig.Fields
Set objMessage.Configuration = objConfig
With Fields
.Item(conSendUsing) = 1 '2为使用外部SMTP服务器,不要更改
.Item(conServer) = mailSmtp '改成可用的外部邮件服务器域名
.Item(conPickupPackage) = "C:\Inetpub\mailroot\pickup"
'如果使用外部smtp服务器，则不需要配置此值
.Item(conServerPort) = 25
'外部SMTP服务器端口,gmail使用465,其它一般使用25
.Item(conConnectionTimeout) = 10 '设定连接超时，单位秒
.Item(conUsessl) = False
'是否使用SSL安全套接字，gmail为true，其它一般false
.Item(conAuthenticate) = 1 '1为发送邮件需要认证,通常不要更改
.Item(conSendUserName) = sendUserName
.Item(conSendPassword) = sendUserPassword
.Update
End With
With objMessage
.To = Trim(mailTo) '改成接收者的邮件地址
.From = mailFrom
'改成发送人的邮件地址,要和上面的邮件系统相同
.Subject = Trim(mailSubject) '标题
.HTMLBody = "<html><head><meta http-equiv=""Content-Type""
content=""text/html; charset=Shift_JIS"" /></head>"&_
"<body>"&mailBody&"</body></html>" 'HTML邮件正文
.BodyPart.Charset = "Shift_JIS" '邮件编码
.HTMLBodyPart.Charset="Shift_JIS" '邮件HTML格式编码
If Trim(mailAttachment) <> "" Then
.AddAttachment mailAttachment '邮件附件
End If
.Send
End With
Set objMessage = Nothing
Set objConfig = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：根据日期、时间和两组随机数生成相对较为唯一的字符串，常用于文件的
非覆盖保存
'程序输入：循环次数，对于输入错误的字符串，截取第一位转换为对应的ASCII数字
作为循环最大次数
'程序输出：日期、时间、随机数、随机数的拼接字符串如：20110107_161003_93778_
47149
'设计人员：LIUYI027
'设计时间：2011-01-07
'调用举例：Printer GenerateUniqueStr("30")
'**************************************************************************
*****************************************************
Public Function GenerateUniqueStr(p_circle)
If Trim(p_circle) = "" Then
p_circle = randomnumber.Value(11,99)
Else
If isNumeric(p_circle) = False Then
p_circle = ASC(Left(p_circle,1))
If p_circle < 11 Then
p_circle = p_circle + 11
End If
Else
p_circle = Trim(p_circle)
End If
End If
randomNo = randomnumber.Value(10,Abs(p_circle))
For i = 1 to randomNo
randomNum1 = randomnumber.Value(10000,99999)
randomNum2 = Int((99999-10000+1)*rnd+10000)
Next
GenerateUniqueStr =
FormatDate(Now,"yyyymmdd_hh24miss")&"_"&randomNum1&"_"&randomNum2
End Function
'**************************************************************************
*****************************************************
'设计说明：（模仿PL/SQL的to_char(日期)函数）把日期/时间值转化成指定格式的字
符串
'程序输入：日期（当前日期）
'程序输出：固定格式的日期：年格式YYYY，月MM，日DD，时HH，分mm，秒，SS
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：msgbox FormatDate(date&time,'yyyy-mm-dd')
'**************************************************************************
*****************************************************
Function FormatDate(p_date, p_format)
Set parts= CreateObject("Scripting.Dictionary")
parts("yyyy") = CStr(Year(p_date))
parts("yy") = Right(Year(p_date), 2)
parts("mm") = Lpad(Month(p_date), 2, "0")
parts("mi") = Lpad(Minute(p_date), 2, "0") '
设计原因，包含m的必须放在month之前
parts("m") = CStr(Month(p_date))
parts("dd") = Lpad(Day(p_date), 2, "0")
parts("d") = CStr(Day(p_date))
parts("hh24") = Lpad(Hour(p_date), 2, "0")
parts("ss") = Lpad(Second(p_date), 2, "0")
v_result = p_format
For Each part In parts
v_result = Replace(v_result, part, parts(part))
Next
FormatDate = v_result
Set parts = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：（模仿PL/SQL同名函数）将p_str长度扩展到p_width，用p_filling从左
边循环填充，本函数不会截短p_str
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：msgbox Lpad(Second(p_date), 2, "0")
'**************************************************************************
*****************************************************
Function Lpad(p_str, p_width, p_filling)
Lpad = ExpandString(p_filling, p_width - Len(p_str)) & p_str
End Function
'**************************************************************************
*****************************************************
'设计说明：（模仿PL/SQL同名函数）将p_str长度扩展到p_width，用p_filling从左
边循环填充，本函数不会截短p_str
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：msgbox Lpad(Second(p_date), 2, "0")
'**************************************************************************
*****************************************************
Function Rpad(p_str, p_width, p_filling)
Rpad = p_str & ExpandString(p_filling, p_width - Len(p_str))
End Function
'**************************************************************************
*****************************************************
'设计说明：将p_str反复叠加，使其长度扩展（或缩小）到p_width
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：ExpandString("bye",7) 返回 byebyeb ； ExpandString("bye",2)返回
by
'**************************************************************************
*****************************************************
Private Function ExpandString(p_str, p_width)
Dim width0, repeat_times, reminder, i, result
If p_width <= 0 Then
ExpandString = ""
Exit Function
End If
width0 = Len(p_str)
repeat_times = p_width \ width0
reminder = p_width Mod width0
For i = 1 To repeat_times
result = result & p_str
Next
result = result & Left(p_str, reminder)
ExpandString = result
End Function
'**************************************************************************
*****************************************************
'设计说明：从p_str的右边去除to_trim中*包含*的字符
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：RReplaceExp("1234ABC5678","0123456789")返回"1234ABC"
'**************************************************************************
*****************************************************
Function RReplaceExp(p_str, to_Trim)
Dim s, c
s = p_str
Do While True
c = Right(s, 1)
If InStr(to_Trim, c) > 0 Then
s = Left(s, Len(s) - 1)
Else
Exit Do
End If
Loop
RReplaceExp = s
End Function
'**************************************************************************
*****************************************************
'设计说明：从p_str的左边去除to_trim中*包含*的字符
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：LReplaceExp("1234ABC5678","0123456789")返回"ABC5678"
'**************************************************************************
*****************************************************
Function LReplaceExp(p_str, to_Trim)
Dim s, c
s = p_str
Do While True
c = Left(s, 1)
If InStr(to_Trim, c) > 0 Then
s = Right(s, Len(s) - 1)
Else
Exit Do
End If
Loop
LReplaceExp = s
End Function
'**************************************************************************
*****************************************************
'设计说明：判断str是否匹配正则表达式pattern，可以指定是否严格匹配大小写
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：ismatch("hello","^h.*o$",true) 返回true
'**************************************************************************
*****************************************************
Function isMatch(str, pattern, caseStrict)
Dim regex
set regex = New RegExp ' 建立正则表达式。
regex.pattern = pattern ' 设置模式。
regex.ignoreCase = not caseStrict ' 设置是否区分大小写。
isMatch = regex.test(str) ' 执行搜索测试。
End Function
'**************************************************************************
*****************************************************
'设计说明：正则表达式替换
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：replaceReg("helloworld","[aeiou]","") 返回hllwrld
'**************************************************************************
*****************************************************
Function replaceReg(Str, pattern, replacement)
Dim regex
set regex = New RegExp
regex.pattern = pattern
regex.global = True
replaceReg=regex.replace(Str, replacement)
End Function
'**************************************************************************
*****************************************************
'设计说明：用str_array中的变量代替text中的相应位置的?（问号）
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：FormatString("hello ?, I am ?", array("vbs","gaoning")) 返回
hello vbs, I am gaoning
'**************************************************************************
*****************************************************
Function FormatString(text, str_array)
Dim texts, i, t, result
texts=split(text,"?")
i=-1
For each t in texts
If i=-1 Then
result=t
Else
result= result & str_array(i) & t
End If
i=i+1
Next
FormatString= result
End Function
'**************************************************************************
*****************************************************
'设计说明：简化ReportEvent的书写，引自Saffron框架
'程序输入：结果报告状态
'程序输出：结果报告
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：Report Pass
'**************************************************************************
*****************************************************
Public Function Report (status, objtype, text)
Reporter.Filter = rtEnableAll
Reporter.ReportEvent status, objtype, text
End Function
'**************************************************************************
*****************************************************
'设计说明：将字符串两端加上双引号，引自SAFFRON框架
'程序输入：字符串
'程序输出：加了引号的字符串
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：Quote("AAA")返回 "AAA"
'**************************************************************************
*****************************************************
Public Function Quote (txt)
Quote = chr(34) & txt & chr(34)
End Function
'**************************************************************************
*****************************************************
'设计说明：取字符或字符串在一个数组中的位置，引自SAFFRON框架
'程序输入：数组、字符串
'程序输出：位置序号
'设计人员：
'设计时间：2011-01-08
'调用举例：IndexOf(myArray,"something")
'**************************************************************************
*****************************************************
Public Function IndexOf (myArray, str)
val = -1
For i = 0 to UBound(myArray)
If myArray(i) = str Then
val = i
End If
Next
IndexOf = val
End Function
'**************************************************************************
************************************************************
'设计说明：
'
判断一般性的js层抛出的控制提示，根据用户选择如何做后续处理，请注意，该程序
只能用于预期之外的提示处理，预期之内必须自行判断
'
如果不关心页面提示信息是什么，只想把提示信息抓出来，那么匹配关键字输入空值
即可
'程序输入：
' respath------截图文件保存路径
'
judgeKeyWord------用于进行匹配的关键字信息，可用英文半角的逗号分隔，只有所
有关键都在页面找到才视为运行通过
' isExitRun-------对于匹配失败的情况，选择是否彻底退出运行
'程序输出：截图文件
'设计人员：LIUYI027
'设计时间：2011-12-05
'调用举例：Call JudgeErrorForDialog("D:\","请,登录","Y")
'**************************************************************************
************************************************************
Public Sub JudgeErrorForDialog(respath,judgeKeyWord,isExitRun)
On Error Resume Next
Set Wshshell = CreateObject("Wscript.Shell")
'判断用户传入参数
If Trim(judgeKeyWord) = "" Or judgeKeyWord is Null Then
theKeyArray =
"用户选择不做关键字匹配"&Replace(Date,"/","-")&"_"&Replace(Time,":","-"
)
emptyPara = True
End If
theKeyArray = Split(judgeKeyWord,",")
If Trim(Replace(isExitRun,"y","Y")) = "Y" Or isExitRun = True Then
isExitRun = True
ElseIf Trim(Replace(isExitRun,"n","N")) = "N" Or isExitRun = False Then
isExitRun = False
Else
isExitRun = True
Reporter.ReportEvent
micWarning,"请尽量使用【Y/N】来作为您参数","由于本次输入无效，程序将自
动选择在无法完全匹配的时候自动退出运行，请了解！"
End If
'初始化所有打开的IE，以便确认所有的弹出窗口都已经展现在页面上
Set BrowserObject = Description.Create()
BrowserObject("micclass").Value = "Browser"
Set WindowsBrowser = Desktop.ChildObjects(BrowserObject)
brNum = WindowsBrowser.Count
If brNum < 1 Then
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set Wshshell = Nothing
Exit Sub
Else
For bindex = 0 to brNum - 1
WindowsBrowser(bindex).Sync
Next
End If
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set DialogObject = Description.Create()
DialogObject("micclass").Value = "Dialog"
Set WindowsDialog = Desktop.ChildObjects(DialogObject)
dlNum = WindowsDialog.Count
If dlNum < 1 Then
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set Wshshell = Nothing
If emptyPara = True Then
Reporter.ReportEvent
micPass,"没有需要判断的对象","提交之后系统没有任何弹出的页面信息提示
！"
Else
Reporter.ReportEvent
micWarning,"没有需要判断的对象","提交之后系统没有任何弹出的页面信息提
示！"
End If
Exit Sub
End If
For dindex = 0 to dlNum - 1
dlTitle = WindowsDialog(dindex).GetROProperty("text")
nameByTime = GenerateUniqueStr(30)&".png"
fileName =
respath&Environment.Value("TestName")&"_"&Environment.Value("ActionName
")&"_"&nameByTime
'对于弹出的下载窗口，需要用单独的程序处理，错误判断中不做处理，直接关闭
If INStr(dlTitle,"下载") > 0 Or INStr(dlTitle,"安装") > 0 Or
INStr(dlTitle,"另存为") > 0 Or INStr(dlTitle,"保存为") > 0 Then
WindowsDialog(dindex).Close
End If
'Windows
GUI直接处理掉，不在判断范围之内，如果需要使用则请自行修改（注释掉）这一
段
Set Win32Object = Description.Create()
Win32Object("micclass").Value = "WinObject"
Set WindowsObject = WindowsDialog(dindex).ChildObjects(Win32Object)
woNum = WindowsObject.Count
If woNum > 0 Then
For windex = 0 to woNum - 1
winMessage = WindowsObject(windex).GetROProperty("text")
If Not Trim(winMessage) = "" Then
Reporter.ReportEvent
micDone,"程序不做匹配判断的提示信息：",winMessage
End If
Next
Wshshell.AppActivate(dlTitle)
Delay 100
WindowsDialog(dindex).CaptureBitmap fileName
Wshshell.AppActivate(dlTitle)
Delay 400
Wshshell.SendKeys "{ENTER}"
End If
Set WindowsObject = Nothing
Set Win32Object = Nothing
Next
'重新Count页面上的非下载窗口个数
Set WindowsDialog = Nothing
Set WindowsDialog = Desktop.ChildObjects(DialogObject)
diaNum = WindowsDialog.Count
maxCount = 0
For dlindex = 0 to diaNum - 1
dlTitle = WindowsDialog(dlindex).GetROProperty("text")
nameByTime = GenerateUniqueStr(30)&".png"
fileName =
respath&Environment.Value("TestName")&"_"&Environment.Value("ActionName
")&"_"&nameByTime
'对于弹出的信息提示窗口，需要获取其提示信息，以供后续选择处理方式
Set StaticObject = Description.Create()
StaticObject("micclass").Value = "Static"
Set WindowsStatic = WindowsDialog(dlindex).ChildObjects(StaticObject)
stNum = WindowsStatic.Count
For sindex = 0 to stNum - 1
disMessage = WindowsStatic(sindex).GetROProperty("text")
arrindex = 0
For arrindex = 0 To UBound(theKeyArray)
If INStr(disMessage,theKeyArray(arrindex)) > 0 Then
maxCount = maxCount + 1
Reporter.ReportEvent micDone,"关键字匹配成功","关键字【
"&theKeyArray(arrindex)&" 】匹配成功！"
End If
arrindex = arrindex + 1
Next
Next
Wshshell.AppActivate(dlTitle)
Delay 100
WindowsDialog(dlindex).CaptureBitmap fileName
Wshshell.AppActivate(dlTitle)
Delay 400
Wshshell.SendKeys "{ENTER}"
Next
If maxCount < UBound(theKeyArray) + 1 Then
Reporter.ReportEvent
micFail,"函数【JudgeErrorForDialog】关键字匹配失败","您需要匹配【
"&(UBound(theKeyArray) + 1)&" 】个关键字，页面上出现了【 "&maxCount&"
】个！"
If isExitRun = True Then
Set WindowsStatic = Nothing
Set StaticObject = Nothing
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
ExitRun
End If
Else
Reporter.ReportEvent
micPass,"函数【JudgeErrorForDialog】关键字匹配成功","您需要匹配【
"&(UBound(theKeyArray) + 1)&" 】个关键字，页面上出现了【 "&maxCount&"
】个！"
End If
Set WindowsStatic = Nothing
Set StaticObject = Nothing
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：
'
页面抛出未封装的RuntimeExcptions，一般是应用出错或者环境异常所致，对于这种
情况程序直接截图之后退出运行，不可选择
'
不同系统使用开发的习惯有所不同，例如有使用WebTable存放错误信息，有使用页面
短文本结合Link详细文本的方式，请自主改造
'程序输入：
' respath------截图文件保存路径
'
myKeyWords------用于进行匹配的关键字信息，可用英文半角的逗号分隔，只要有任
意关键字在页面找到都视为发现异常，运行退出
'程序输出：截图文件
'设计人员：LIUYI027
'设计时间：2011-12-05
'调用举例：Call
JudgePageExceptions("D:\","Excetion,EXCEPTION,exception,ORA-,详细情况")
'**************************************************************************
************************************************************
Public Sub JudgePageExceptions(respath,myKeyWords)
On Error Resume Next
Set Wshshell = CreateObject("Wscript.Shell")
'因为一旦出错立刻停止运行，不会出现多次截图导致的文件名冲突，故文件名只赋
一次值
nameByTime = GenerateUniqueStr(30)&".png"
fileName =
respath&Environment.Value("TestName")&"_"&Environment.Value("ActionName")
&"_"&nameByTime
'如果输入为空，则组合一个不大可能出现的错误信息出来，想必不会哪个系统出这
种Exception的：）
If Trim(myKeyWords) = "" Or myKeyWords is Null Then
myKeyWords =
myKeyWords&"用户选择不做关键字匹配"&Replace(Date,"/","-")&"_"&Replace(T
ime,":","-")
End If
theKeyArray = Split(myKeyWord,",")
Set BrowserObj = Description.Create()
BrowserObj("micclass").Value = "Browser"
Set Win32Browser = Desktop.ChildObjects(BrowserObj)
brNum = Win32Browser.Count
If brNum < 1 Then
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set Wshshell = Nothing
Exit Sub
End If
For bindex = 0 to brNum - 1
Win32Browser(bindex).Sync
Set PageObj = Description.Create()
PageObj("micclass").value = "Page"
Set Win32Page = Win32Browser(bindex).ChildObjects(PageObj)
pgNum = Win32Page.Count
For pindex = 0 to pgNum - 1
Set FrameObj = Description.Create()
FrameObj("micclass").Value = "Frame"
Set Win32Frame = Win32Page(pindex).ChildObjects(FrameObj)
frNum = Win32Frame.Count
'对于页面上的出错信息，如果存在使用LINK链接的错误文本信息则点开并且截
图，链接名称为需要匹配的关键字之一
For findex = 0 to frNum - 1
Set LinkObj = Description.Create()
LinkObj("micclass").Value = "Link"
Set Win32Link = Win32Frame(findex).ChildObjects(LinkObj)
liNum = Win32Link.Count
'判断是数组中的元素多还是页面上的Link多，选择少的做循环外部驱动，这
样可以适当提高性能
If lindex < UBound(theKeyArray) + 1 Then
For lindex = 0 to liNum - 1
linkText = Win32Link(lindex).GetROProperty("text")
For aindex = 0 To UBound(theKeyArray)
theKeyWord = theKeyArray(aindex)
brTit = Win32Browser(bindex).GetROProperty("title")
If InStr(lindex,theKeyWord) > 0 Then
Win32Link(lindex).Click
Win32Browser(bindex).Sync
Wshshell.AppActivate(brTit)
Delay 100
Win32Browser(bindex).CaptureBitmap fileName
Reporter.ReportEvent
micFail,"
*****************************************************
'有用的没用的都丢到一起，可能会有你想要的，原本是分为FileOper、DataOper、We
bOper（基于SAFFRON）、Win32Oper和ErrorOper五个文件
'后面三个超级啰嗦超级长的废物可能别人用不到，不过构造思路比较清晰，大家可以
DIY一下，或许你会觉得很方便，至少可以不用CheckPoint
'**************************************************************************
*****************************************************
classArray = Split("Browser,Page,Frame",",")
descArray = Split("micclass:=Browser,micclass:=Page,micclass:=Frame,",",")
objectArray = Split("Link,WebButton,WebList,WebEdit,Image", ",")
objectDescArray =
Split("micclass:=Link,micclass:=WebButton,micclass:=WebList,micclass:=WebEd
it,micclass:=Image", ",")
'**************************************************************************
*****************************************************
'设计说明：关闭所有打开的IE
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：CloseBrowsers
'**************************************************************************
*****************************************************
Public Sub CloseAllBrowser
Set Wshshell = CreateObject("Wscript.Shell")
Set DialogObject = Description.Create()
DialogObject("micclass").Value = "Dialog"
Set Windows32Dialog = Desktop.ChildObjects(DialogObject)
dlNum = Windows32Dialog.Count - 1
For v = 0 to dlNum
Windows32Dialog(v).Close
Next
Set Windows32Dialog = Nothing
Set theBrowser = Browser("micclass:=Browser", "index:=0")
While theBrowser.Exist(0)
theBrowser.Close
'有些系统页面可能在关闭的时候会有提示对话框出现
waitNx = 1
Do While waitNx < 5
Set Windows32Dialog = Desktop.ChildObjects(DialogObject)
dlNum = Windows32Dialog.Count - 1
For v = 0 to dlNum
dlText = Windows32Dialog(v).GetROProperty("regexpwndtitle")
Wshshell.AppActivate(dlText)
Wait(1)
Wshshell.SendKeys "{ENTER}"
Next
Set Windows32Dialog = Nothing
waitNx = waitNx + 1
Loop
Report
Pass,"使用CloseAllOpenedBrowsers函数页面关闭成功","当前页面关闭成功！"
Wend
Set theBrowser = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：最大化IE浏览器
'程序输入：无
'程序输出：无
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：MaximizeBrowser
'**************************************************************************
*****************************************************
Sub MaximizeBrowser
Set BrowserObject = Description.Create()
BrowserObject("NativeClass").Value = "IEFrame"
Set WindowsBrowser = Desktop.ChildObjects(BrowserObject)
brNum = WindowsBrowser.Count - 1
For i = 0 To brNum
ieVersion = WindowsBrowser(i).GetROProperty("version")
wndTitle = WindowsBrowser(i).GetROProperty("title")
Set ObjectBrowser = Browser("micclass:=Browser", "index:="&i)
If Instr(ieVersion,6) > 0 Then
Window("regexpwndclass:=IEFrame","index:=0","text:="&wndTitle&".*").M
aximize
Else
WindowsBrowser(i).Maximize
End If
Set ObjectBrowser = Nothing
Next
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：根据对象属性列表和属性值列表匹配Browser对象，该函数基本无用… …
'程序输入：对象属性列表和属性值列表，列表使用英文半角的逗号分隔
'程序输出：创建对象
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：GenerateBrowserObject("name,title","保险业务管理系统,保险业务管
理系统")
'**************************************************************************
*****************************************************
Public Function GenerateBrowser(p_Attlist,p_Keylist)
AttArray = Split(p_Attlist,",")
KeyArray = Split(p_Keylist,",")
exeStr = "Browser("
If UBound(AttArray) <> UBound(KeyArray) Then
Report
Fail,"使用GenerateBrowserObject函数参数输入错误","对象属性的个数应该与
其对应的属性值个数相等！"
Exit Function
End If
For inx = 0 to UBound(AttArray)
exeStr =
exeStr&Chr(34)&AttArray(inx)&":=.*"&KeyArray(inx)&".*"&Chr(34)&","
Next
Execute "Set MyObject = "&exeStr&Quote("index:=0")&")"
If MyObject.Exist(0) Then
Report
Pass,"使用GenerateBrowserObject函数构造对象成功","按照Browser对象属性列
表【"&p_Attlist&"】，属性值列表【"&p_Keylist&"】，生成Browser对象成功！
"
Else
Report
Fail,"使用GenerateBrowserObject函数构造对象失败","按照Browser对象按照属
性列表【"&p_Attlist&"】，属性值列表【"&p_Keylist&"】，匹配Browser对象失
败！"
ExitRun
End If
Set GenerateBrowser = MyObject
End Function
'**************************************************************************
*****************************************************
'设计说明：初始化所有打开的Browser页面，不厌设计复杂只为稳定高效
'程序输入：无
'程序输出：初始化成功或者失败
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：BrowserSync
'**************************************************************************
*****************************************************
Public Function SyncronizeBrowser()
Set MyBrowser = Browser("micclass:=Browser", "index:=0")
If MyBrowser.Exist(0) Then
MyBrowser.Sync
Do Until MyBrowser.GetROProperty("url") <> "" And
MyBrowser.GetROProperty("name") <> ""
Delay 50
Loop
Else
Set MyBrowser = Nothing
SyncronizeBrowser = False
Report Warning ,"初始化页面失败","页面初始化失败，需要重新操作！"
Exit Function
End If
Set MyBrowser = Nothing
SyncronizeBrowser = True
End Function
'**************************************************************************
*****************************************************
'设计说明：打开指定的地址，并且初始化页面，特别说明：对于地址栏出现一次性se
ssionid的网页不可用该函数
'程序输入：url地址
'程序输出：初始化成功或者失败
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：print SyncronizeSepecifiedURL("www.baidu.com")
'**************************************************************************
*****************************************************
Public Function NavigateBrowser(para_myuri)
CloseAllBrowser
Set IEBrowser = CreateObject("InternetExplorer.Application")
IEBrowser.Visible = True
IEBrowser.Navigate para_myuri
Set ObjectBrowser = Browser("micclass:=Browser", "index:=0")
Do Until SyncronizeBrowser() = True
Wait(1)
Loop
actualurl = ObjectBrowser.GetROProperty("url")
'下面这个判断主要是为了解决初始化地址跳转问题，如果URL发生变化会导致对象
属性发生变化从而导致运行错误。
If actualurl <> para_myuri Then
ObjectBrowser.Close
Set IEBrowser = Nothing
Set IEBrowser = CreateObject("InternetExplorer.Application")
IEBrowser.Visible = True
IEBrowser.Navigate actualurl
If Not SyncronizeBrowser() Then
Report
Warning,"使用NavigateBrowser函数IE初始化失败","打开指定页面【"&myuri&
"】在初始化的时候失败！"
Set MyBrowser = Nothing
Set IEBrowser = Nothing
Exit Function
End If
End If
Set ObjectBrowser = Nothing
Set IEBrowser = Nothing
Report
Pass,"使用NavigateBrowser函数IE初始化成功","打开指定页面【"¶_myuri&"
】并且初始化成功！"
NavigateBrowser = True
End Function
'**************************************************************************
*****************************************************
'设计说明：处理弹出对话框，主要用于弹出的可预知性能够得到控制的地方，未知弹
出需引用其他函数处理
'程序输入：选择对话框操作：是/否/确认/取消/确定等等，是否需要向结果中添加提
示信息的报告
'程序输出：结果报告
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：HandleDialog "确认","Y"
'**************************************************************************
*****************************************************
Public Function HandleDialog(regexpName,needAlertInfo)
If Trim(regexpName) = "" Then
regexpName = "无需匹配的按钮！"
End If
Set Wshshell = CreateObject("Wscript.Shell")
Set DialogObject = Description.Create()
DialogObject("micclass").Value = "Dialog"
Set WindowsDialog = Desktop.ChildObjects(DialogObject)
dlNum = WindowsDialog.Count - 1
If dlNum < 0 Then
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Report micDone,"没有任何弹出框","不需要进行对话框的处理！"
Exit Function
End If
For inx = 0 to dlNum
If needAlertInfo = "Y" Or needAlertInfo = True Then
Set StaticObject = Description.Create()
StaticObject("micclass").Value = "Static"
Set WindowsStatic = WindowsDialog(inx).ChildObjects(StaticObject)
stNum = WindowsStatic.Count
disMessage = WindowsStatic(stNum - 1).GetROProperty("text")
Report micDone,"获取网页对话框信息成功：",disMessage
Set WindowsStatic = Nothing
Set StaticObject = Nothing
End If
dialogTitle = WindowsDialog(inx).GetROProperty("text")
Set WinButtonObject = Description.Create()
WinButtonObject("micclass").Value = "WinButton"
Set WindowsButton = WindowsDialog(inx).ChildObjects(WinButtonObject)
wbNum = WindowsButton.Count - 1
For binx = 0 to wbNum
btName = WindowsButton(binx).GetROProperty("text")
If Instr(btName,regexpName) > 0 Then
WindowsButton(binx).Click
Report
Pass,"函数HandleDialog点击指定按钮成功","按照指定的按钮名称【"®e
xpName&"】查找并点击按钮成功！"
Exit For
End If
If binx = wbNum And Instr(btName,regexpName) = 0 Then
Wshshell.AppActivate(dialogTitle)
Wait(0)
Wshshell.SendKeys "{ENTER}"
Report
micWarning,"函数HandleDialog点击按钮","没有匹配到指定按钮，对已经弹
出的对话框直接使用默认操作！"
End If
Next
Set WindowsButton = Nothing
Set WinButtonObject = Nothing
Next
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：SAFFRON框架引用以及部分改造，函数分流之后的部分
'程序输入：参见各个函数
'程序输出：
'设计人员：
'设计时间：2011-01-08
'调用举例：
'**************************************************************************
*****************************************************
Public Function GenerateDescription (classString,isModleWindow)
classNx = IndexOf(classArray, classString)
If classNx >= 0 Then
'增加对模态窗口的支持
If isModleWindow = "Y" Or isModleWindow = True Then
descString = "Window("&Quote("nativeclass:=Internet
Explorer_TridentDlgFrame")&")."
Else
descString = classArray(0)&"("&Quote(descArray(0))&")."
End If
If classNx >= 1 Then
descString = descString + classArray(1)&"("&Quote(descArray(1))&")."
If 2 >= classNx Then
If hasFrameValue <> "" Then
descString = descString +
classArray(2)&"("&Quote(descArray(2))&","&Quote("name:="&hasFrame
Value)&")."
End If
End If
End If
End If
GenerateDescription = descString
End Function
'**************************************************************************
**********************************************
Public Function GenerateObjectDescription (objClassName, otherAtt)
objNx = IndexOf(objectArray, objClassName)
objNameString = ""
If objNx <> -1 Then
objNameString =
objClassName&"("&Quote(objectDescArray(objNx))&","&Quote(otherAtt)&","&
Quote("index:=0")&")."
End If
GenerateobjectDescription = objNameString
End Function
'**************************************************************************
**********************************************
Public Function ObjectWorkUnderFrame(frameName)
hasFrameValue = frameName
End Function
'**************************************************************************
**********************************************
Public Function ObjectNotWorkUnderFrame()
hasFrameValue = ""
End Function
'**************************************************************************
**********************************************
Public Function VerifyObject (objectClassName, text,isModleWindow)
rval = false
localDesc = ""
estr = ""
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
Select Case objectClassName
Case "Page"
Execute "rval =
"&GenerateDescription(classArray(1),isModleWindow)&"Exist (0)"
If rval Then
Execute "title =
"&GenerateDescription(classArray(1),isModleWindow)&"GetROProperty("
&Quote("title")&")"
If title = text Then
rval = true
Else
rval = false
End If
End If
Case "CurrentFrame"
If hasFrameValue <> "" Then
estr = "rval = "&localDesc
End If
Case "Link"
estr = "rval = "&localDesc&GenerateObjectDescription("Link",
"innertext:=.*"&text&".*")
Case "WebButton"
estr = "rval = "&localDesc&GenerateObjectDescription("WebButton",
"value:=.*"&text&".*")
Case "WebList"
estr = "rval = "&localDesc&GenerateObjectDescription("WebList",
"name:=.*"&text&".*")
Case "WebEdit"
estr = "rval = "&localDesc&GenerateObjectDescription("WebEdit",
"name:=.*"&text&".*")
End Select
If estr <> "" Then
Execute estr + "Exist (0)"
End If
If rval Then
Report micDone, objectClassName&"匹配对象成功",
"对象【"&objectClassName&"】【 "&Quote(text)&" 】查询成功！"
VerifyObject = True
Else
Report Warning, objectClassName&"匹配对象失败",
"对象【"&objectClassName&"】【 "&Quote(text)&" 】查询无果！"
VerifyObject = False
End If
End Function
'**************************************************************************
**********************************************
Public Function ClickSpecifiedObject (objectClassName, text, isModleWindow)
localDesc = ""
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
Select Case objectClassName
Case "Link"
Execute
localDesc&GenerateObjectDescription("Link","innertext:=.*"&text&".*")
&"Click"
SyncronizeBrowser
Report micDone,
"链接点击完成：","链接【"&text&"】点击完毕，并且已经执行网页初始化！"
Case "WebButton"
Execute localDesc&GenerateObjectDescription("WebButton",
"value:=.*"&text&".*")&"Click"
SyncronizeBrowser
Report micDone, "按钮点击完成：",
"按钮【"&text&"】点击完毕，并且已经执行网页初始化！"
Case "Image"
Execute localDesc&GenerateObjectDescription("Image",
"alt:=.*"&text&".*")&"Click"
SyncronizeBrowser
Report micDone, "图标点击完成：",
"图标【"&text&"】点击完毕，并且已经执行网页初始化！"
End Select
End Function
'**************************************************************************
**********************************************
Public Function SelectFromList (objectName, text, isModleWindow)
localDesc = ""
rv = ""
rval = false
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
localDesc = localdesc&GenerateObjectDescription("WebList",
"name:=.*"&objectName&".*")
Execute "cnt = "&localDesc&"GetROProperty("&Quote("items count")&")"
For i = 1 to cnt
Execute "rv = "&localDesc&"GetItem ("&i&")"
If rv = text Then
rval = true
End If
Next
If rval Then
Execute localDesc&"Select "&Quote(text)
SyncronizeBrowser
Report micDone, "下拉列表选择成功",
"选择项【"&text&"】已经被查询到、选择，并且执行初始化！"
Else
Report micFail, "下拉列表选择失败",
"选择项【"&text&"】没有在下拉列表【"&objectName&"】中查询到查询到！"
Exit Function
End If
SelectFromList = True
End Function
'**************************************************************************
**********************************************
Public Function EnterValueForEdit (objectName, text,isModleWindow)
localDesc = ""
rval = true
If hasFrameValue <> "" Then
localDesc = GenerateDescription(classArray(2),isModleWindow)
Else
localDesc = GenerateDescription(classArray(1),isModleWindow)
End If
localDesc = localdesc&GenerateObjectDescription("WebEdit",
"name:=.*"&objectName&".*")
Execute localDesc&"Set ("&Quote(text)&")"
Report micDone, "文本框输入操作：",
"文本【"&text&"】成功输入到输入框【"&objectName&"】!"
EnterValueForEdit = rval
End Function
'**************************************************************************
*****************************************************
'设计说明：从数据库中抓取指定表和列的数据，依赖ORAOLEDB组件的正常使用，不用
创建数据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 要抓取的字段
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：要抓取的字段
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：MsgBox FetchDBDataOle("select * from
plan","plan_code","A","10.31.10.105","1555","B","C")
'**************************************************************************
*****************************************************
Public Function
FetchDBData(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,sqlText,
tableColumn)
Set DBRec=createobject("adodb.recordset")
Set DBCon=createobject("adodb.Connection")
DBCon.ConnectionString="Provider=""OraOLEDB.Oracle"";User ID="&_
DBUserName &";Data Source=""(description =(address = (protocol =
tcp)(host = "&_
DBHostAddress &")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBCon.Open
DBRec.Open sqlText,DBCon
FetchDBData = DBRec.Fields(tableColumn)
DBCon.Close
Set DBRec = Nothing
Set DBCon = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：从数据库中抓取指定表和列的数据，基于MSDAORA对象的使用，不依赖ORA
OLEDB，不用创建数据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 要抓取的字段
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：要抓取的字段
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：MsgBox FetchDBData("select * from
plan","plan_code","A","10.31.10.105","1555","B","C")
'**************************************************************************
*****************************************************
Public Function
FetchDBDataMSDAORA(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,s
qlText,tableColumn)
Set DBCon = CreateObject("ADODB.Connection")
Set DBRec = CreateObject("ADODB.RecordSet")
DBCon.Open = "Provider=""MSDAORA.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress &")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBRec.OPEN sqlText,DBCon
FetchDBDataMSDAORA = DBRec.fields(tableColumn)
DBCon.close
Set DBCon =Nothing
Set DBRec = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：按照传入SQL修改数据库的值，依赖ORAOLEDB组件的正常使用，不用创建
数据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：无
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：Call ModifyDBDataOle("A","10.31.10.105","1555","B","C"，"update
Test set Col = 'A' where Col = 'B'")
'**************************************************************************
*****************************************************
Public Sub
ModifyDBData(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,sqlText
)
Set DBRec=createobject("adodb.recordset")
Set DBCom=createobject("adodb.command")
DBCom.activeconnection="Provider=""OraOLEDB.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress&")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBCom.CommandType = 1
DBCom.CommandText = sqlText
Set DBRec = DBCom.Execute()
DBCom.CommandText = "commit"
Set DBRec = DBCom.Execute()
Set DBRec = Nothing
Set DBCom = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：按照传入SQL修改数据库的值，不依赖ORAOLEDB组件的使用，不用创建数
据源，不用配置连接串
'程序输入：
' 要执行的sql语句
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：无
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：Call ModifyDBData("A","10.31.10.105","1555","B","C"，"update
Test set Col = 'A' where Col = 'B'")
'**************************************************************************
*****************************************************
Public Sub
ModifyDBDataMSDAORA(DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWord,
sqlText)
Set DBCon = CreateObject("ADODB.Connection")
Set DBRec = CreateObject("ADODB.RecordSet")
DBCon.Open = "Provider=""MSDAORA.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress &")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBRec.OPEN sqlText,DBCon
DBRec.OPEN "commit",DBCon
DBCon.Close
Set DBCon =Nothing
Set DBRec = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：调用存储过程，不依赖ORAOLEDB组件的使用，不用创建数据源，不用配置
连接串
'程序输入：
' 要执行的存储过程名
' 数据库用户名
' 数据库主机的域名或IP
' 数据库主机的端口
' 数据库实例SID
' 数据库用户的密码
'程序输出：无
'设计人员: LIUYI027
'设计时间：2009-09-26
'调用举例：Call
RunProcedure("gbsjob.job_package.gbs_job4","pub_test","10.31.9.62","1562","
gs30gbs","test2012")
'**************************************************************************
*****************************************************
Sub
RunProcedure(procName,DBUserName,DBHostAddress,DBServerPort,DBSid,DBPassWor
d)
Set DBCon = CreateObject("ADODB.Connection")
Set DBRec = CreateObject("ADODB.RecordSet")
Set DBcom = CreateObject("ADODB.Command")
DBCon.Open = "Provider=""MSDAORA.Oracle"";User ID="&_
DBUserName&";Data Source=""(description =(address = (protocol = tcp)(host
= "&_
DBHostAddress&")(port = "&_
DBServerPort&"))(connect_data =(sid = "&_
DBSid&")))"";Password="&_
DBPassWord&""
DBcom.ActiveConnection = DBCon
DBcom.CommandType = 4
DBcom.CommandText = procName
DBcom.Execute
DBcom.CommandText = "commit"
DBcom.Execute
DBCon.close
Set DBcom = Nothing
Set DBCon =Nothing
Set DBRec = Nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：用于将EXCEL中某个SHEET单独COPY出来到一个临时的文件中，从临时文件
导入DATATABLE，避免SHEET过多导致的EXCEL出错
'程序输入：
' originalDataFile： 原EXCEL
' tempFileForImpt： 新的临时文件
' oldSheet： 原EXCEL的SHEET
' newSheet： 新的EXCEL临时SHEET
'程序输出：将指定路径下的指定EXCEL的指定SHEET导入DataTable
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例：Call impXls("D:\test.xls","D:\temp.xls","原始SHEET","新的SHEET")
'**************************************************************************
********************************************************************
Public Sub impXls(originalDataFile,tempFileForImpt,oldSheet,newSheet)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Application.Visible = False
If (Fso.FileExists(originalDataFile) = False) Then
Reporter.ReportEvent micFail,"参数文件不存在：",originalDataFile
Print "参数文件不存在："&originalDataFile
Set newBook = Nothing
ExcelApp.Quit
Set ExcelApp = Nothing
Set Fso = Nothing
Exit Sub
End If
Set newBook = ExcelApp.Workbooks.Open (originalDataFile,False,True)
newBook.Worksheets(oldSheet).copy
Set tempBook=ExcelApp.ActiveWorkbook
If (Fso.FileExists(tempFileForImpt) = True) Then
Set tempxls = Fso.GetFile(tempFileForImpt)
tempxls.Delete
tempBook.SaveAs tempFileForImpt
Set tempxls = Nothing
Else
tempBook.SaveAs tempFileForImpt
End If
Set tempBook = Nothing
ExcelApp.Quit
Set ExcelApp = Nothing
DataTable.AddSheet newSheet
DataTable.ImportSheet tempFileForImpt,oldSheet,newSheet
If (Fso.FileExists(tempFileForImpt) = True) Then
Set tempFile = fso.GetFile(tempFileForImpt)
tempFile.Delete
Set tempFile = Nothing
End If
Set Fso = Nothing
Reporter.ReportEvent
micPass,"导入参数文件成功：","文件：【"&originalDataFile&"】，SHEET页：【
"&newSheet&"】"
End Sub
'**************************************************************************
********************************************************************
'设计说明：写指定行和列的EXCEL的值
'程序输入：
' sheet： 写入的SHEET；
' row： 指定行；
' col： 指定的行；
' value： 写入值；
' pathAndFile： 文件路径
'程序输出：写入指定单元格，无需返回
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call WExcel("指定页",3,4,date,"D:\test.xls")
'**************************************************************************
********************************************************************
Public Sub WExcel(sheet,row,col,value,pathAndFile)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
If Fso.FileExists(pathAndFile) = True Then
Set newBook = ExcelApp.Workbooks.Open(pathAndFile)
newBook.Worksheets(sheet).Activate
newBook.Worksheets(sheet).Cells(row,col).value=value
newBook.Save
ExcelApp.Application.Quit
Else
Set newBook = ExcelApp.Workbooks.Add
newBook.Worksheets(sheet).Activate
newBook.Worksheets(sheet).Cells(row,col).value=value
newBook.SaveAs pathAndFile
ExcelApp.Application.Quit
End If
Set newBook = Nothing
Set ExcelApp = Nothing
Set Fso = Nothing
Set Wshshell = Nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：读指定行和列的EXCEL的值
'程序输入：
' sheet： 读取的SHEET；
' row： 指定行；
' col： 指定的行；
' pathAndFile： 文件路径
'程序输出：读取的指定单元格的值
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Msgbox getCellValue("指定页",3,4,"D:\test.xls")
'**************************************************************************
********************************************************************
Public Function getCellValue(sheet, row, column, pathAndFile)
Set Wshshell = CreateObject("Wscript.shell")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ExcelApp = CreateObject("excel.Application")
ExcelApp.Visible = False
If Fso.FileExists(pathAndFile) = True Then
Set newBook = ExcelApp.Workbooks.Open(pathAndFile,False,True)
Set excelSheet = newBook.Worksheets(sheet)
excelSheet.Activate
GetCellValue = excelSheet.Cells(row, column)
Set excelSheet = Nothing
Else
Reporter.ReportEvent
micFail,"未找到文件","指定文件：【"&originalDataFile&"】未找到，请确认
文件路径！"
Print "指定文件：【"&originalDataFile&"】未找到，请确认文件路径！"
End If
ExcelApp.Quit
Set ExcelApp = Nothing
Set Fso = Nothing
Set Wshshell = Nothing
End Function
'**************************************************************************
********************************************************************
'设计说明：读取以IE打开的EXCEL指定行和列的值
'程序输入：
' row： 指定行；
' col： 指定的行；
' url： IE地址url，一般可使用正则表达式来识别;
' tit： 网页标题
'程序输出：读取的指定单元格的值
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Msgbox
ieXlsValue(3,4,"http://ehis-nbs-stg.paic.com.cn/ehis/.*","^.*健康险.*")
'**************************************************************************
********************************************************************
Public Function ieXlsValue(row, column, url,tit)
on error resume Next
Set Wshshell = CreateObject("Wscript.shell")
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.navigate url
If Browser("title:="&tit).Exist(2) Then
Browser("title:="&tit).WinButton("Name:=打 开").Click
End If
For v = 1 To 5
If Dialog("Name:=Microsoft Excel").Exist(1) Then
Dialog("Name:=Microsoft Excel").WinButton("Name:=确定").Click
End If
Next
Set ExcelApp = Getobject(0,"excel.Application")
If Err = 0 Then
Set excelSheet = ExcelApp.ActiveSheet
excelSheet.Activate
GetCellValue = excelSheet.Cells(row, column)
Set excelSheet = Nothing
Else
Print "文件不存在！请确认IE中已经打开EXCEL页！"
End If
ExcelApp.Quit
Set ExcelApp = Nothing
Set Wshshell = Nothing
Set IE = Nothing
End Function
'**************************************************************************
********************************************************************
'设计说明：写入纯文本TXT文件
'程序输入：
' filepath： 文件路径和文件名组合；
' text： 写入值
'程序输出：写入txt，无需返回值
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call txtWrite("D:\test.txt","写入什么值")
'**************************************************************************
********************************************************************
Public Sub txtWrite(filepath,text)
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(filepath, True)
MyFile.Write(text)
MyFile.Close
Set MyFile = nothing
Set fso = nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：读取整个txt文本文件的值
'程序输入：filepath：txt文本文件所在路径和文件名的组合
'程序输出：整个TXT文件的内容。
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Msgbox txtRead("D:\text.txt")
'**************************************************************************
********************************************************************
Public Function txtReadAll(rfilepath)
Const ForReading = 1, ForWriting = 2
Dim fso, MyFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.OpenTextFile(rfilepath, ForReading)
txtRead = MyFile.readAll
Set MyFile = nothing
Set fso = nothing
End Function
'**************************************************************************
********************************************************************
'设计说明：从磁盘上删除指定txt文本文件
'程序输入：filepath：txt文本文件所在路径和文件名的组合
'程序输出：删除操作过程，无需返回
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call txtDelete("D:\text.txt")
'**************************************************************************
********************************************************************
Public Sub txtDelete(filepath)
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(filepath)
Set fso = Nothing
End Sub
'**************************************************************************
********************************************************************
'设计说明：指定上载文件中特定字符后指定长度的字符使用另一指定字符替换，逐行
处理、直至结束（剔除首行）
'程序输入：
' FilePath： 文件路径
' FileName： 文件名称
' SpecifiedStrMark： 指定字符
' replaceLength： 替换长度
' ReplaceWith： 用来替换的串
'程序输出：删除操作过程，无需返回
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例： Call
ReplaceStr(FilePath,FileName,SpecifiedStrMark,replaceLength,ReplaceWith)
'**************************************************************************
********************************************************************
Public Sub
ReplaceStr(FilePath,FileName,SpecifiedStrMark,replaceLength,ReplaceWith)
If len(ReplaceWith) <> Abs(replaceLength) Then
Reporter.ReportEvent
micFail,"参数使用错误","请确认需要替换的长度与新的替换字符串长度一致！"
Print "参数使用错误:ReplaceWith参数长度要与replaceLength值一致！"
Exit Sub
End If
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set Fso = CreateObject("Scripting.FileSystemObject")
If Not Fso.FileExists(FilePath&FileName) Then
Reporter.ReportEvent
micFail,"参数使用错误","请确认指定的文件是否存在！"
"参数使用错误:"&FilePath&FileName&"，请确认该指定的文件是否存在！"
Exit Sub
End If
Set MyOldFile = fso.OpenTextFile(FilePath&FileName, ForReading)
If Fso.FileExists(FilePath&"temp.txt") Then
Fso.DeleteFile(FilePath&"temp.txt")
End If
Set tmpFile = Fso.CreateTextFile(FilePath&"temp.txt",True)
v = 1
While Not MyOldFile.AtEndOfStream
orgStr = MyOldFile.readLine
If v > 1 Then
If instr(orgStr,SpecifiedStrMark) > 0 Then
timeMark =
Mid(orgStr,instr(orgStr,SpecifiedStrMark)+len(SpecifiedStrMark),r
eplaceLength)
newStr = Replace(orgStr,timeMark,ReplaceWith)
tmpFile.WriteLine(newStr)
Else
tmpFile.WriteLine(orgStr)
End If
Else
tmpFile.WriteLine(orgStr)
End If
v = v + 1
Wend
tmpFile.Close
MyOldFile.Close
Set tmpFile = Nothing
Set MyOldFile = Nothing
Set MyNewFile = Fso.OpenTextFile(FilePath&FileName, ForWriting)
Set MyTemFile = Fso.OpenTextFile(FilePath&"temp.txt", ForReading)
transStr = MyTemFile.ReadAll
MyNewFile.Write (transStr)
MyNewFile.Close
MyTemFile.Close
Fso.DeleteFile(FilePath&"temp.txt")
Set MyTemFile = Nothing
Set MyNewFile = Nothing
Set Fso = Nothing
End Sub
'**************************************************************************
*****************************************************
'设计说明：低级算法加密：密码明文加密，ASCII加随机整数拼装，如有需要可直接
写入TXT或EXCEL文件中去。
'程序输入：密码明文
'程序输出：加密字符串
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例：msgbox to_num("aaaaa888")
'**************************************************************************
*****************************************************
Public Function to_num(password)
Set Wshshell = Createobject("wscript.shell")
n = len(password)
i = 1
str = ""
Do while i <= n
If len(asc(mid(password,i,1))) = 1 Then
tran = "00"&asc(mid(password,i,1))
Elseif len(asc(mid(password,i,1))) = 2 Then
tran = "0"&asc(mid(password,i,1))
Else
tran = asc(mid(password,i,1))
End If
rank1 = Int(8*Rnd+1)
rank2 = Int(25*Rnd + 65)
char = (rank1-1)&chr(rank2)&rank1&chr(rank2+1)&(rank1+1)
str = str&tran&char
i = i + 1
Loop
to_num = str
End Function
'**************************************************************************
*****************************************************
'设计说明：如上to_num加密函数的对应解密函数
'程序输入：str：密文字符串
'程序输出：原始密码明文
'设计人员：LIUYI027
'设计时间：2008-11-05
'调用举例：msgbox
openText("0975N6O70974H5I60972T3U40970T1U20976R7S80560K1L20566T7U80562Y3Z4"
)'
**************************************************************************
*****************************************************
Public Function openText(str)
n = len(str)/8
res = ""
Do
n = len(str)/8
char = chr(mid(str,1,3))
str = right(str,8*n-8)
res = res&char
If n = 1 Then
Exit Do
End If
Loop
openText = res
End Function
'**************************************************************************
************************************************************
'设计说明：查找指定进程
'程序输入：进程名称，如EXCEL.EXE
'程序输出：成功或者失败True/False
'设计人员：LIUYI027/PAICDOM
'设计时间：2010-01-05
'调用举例：Msgbox GetProcess("EXCEL")或msgbox GetProcess("EXCEL.EXE")
'**************************************************************************
************************************************************
Public Sub GetProcess(prcessName)
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set Processes = objWMIService.ExecQuery("select * from Win32_Process")
For Each Process In Processes
If InStr(UCase(Process.Name),UCase(prcessName)) > 0 Then
GetProcess = True
Else
GetProcess = False
End If
Next
Set Process = Nothing
Set objWMIService = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：用于将进程强行关闭，常用语EXCEL进程处理
'程序输入：进程名称，如EXCEL.EXE
'程序输出：关闭对应的进程
'设计人员：LIUYI027/PAICDOM
'设计时间：2010-01-05
'调用举例：Call KillProcess("EXCEL")或Call KillProcess("EXCEL.EXE")
'**************************************************************************
************************************************************
Public Sub KillProcess(prcessName)
If Len(prcessName) < 3 Then
Report
Warning,"使用函数KillProcess输入进程名称过短","过短的进程名称可能会匹配
到多个进程，操作将非常危险，请停止操作！"
Exit Sub
End If
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set Processes = objWMIService.ExecQuery("select * from Win32_Process")
For Each Process In Processes
If InStr(UCase(Process.Name),UCase(prcessName)) > 0 Then
SystemUtil.CloseProcessByName(Process.Name)
Report
Done,"系统出现"&UCase(prcessName)&"进程异常","该进程已经使用函数KillP
rocess强行关闭！"
End If
Next
Set Process = Nothing
Set objWMIService = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：解决快速运行中低于1秒的等待
'程序输入：循环次数，每次循环大约11.6毫秒
'程序输出：无
'设计人员：LIUYI027
'设计时间：2010-12-13
'调用举例：Delay 1000大约等待8秒，Delay 100大约等待1.157秒
'**************************************************************************
************************************************************
Public Sub Delay(i)
For x = 0 to i
a = x
Next
End Sub
'**************************************************************************
************************************************************
'设计说明：修改IE8的注册信息以便于运行
'程序输入：无
'程序输出：无
'设计人员：LIUYI027
'设计时间：2010-12-31
'调用举例：Call ModIERegForAutoMation()
'**************************************************************************
************************************************************
Public Sub ModIERegForAutomation
Set objShell = CreateObject("WScript.Shell")
'显示菜单栏
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\Main\AlwaysShowMenus",1,"REG_DWORD"
'显示收藏夹栏
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\LinksBar\Enabled",1,"REG_DWORD"
'菜单栏置顶
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\Toolbar\WebBrowser\ITBar7Position",1,"REG_DWORD"
'遇到弹出窗口时始终在新选项卡中打开弹出窗口
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\TabbedBrowsing\PopupsUseNewWindow",1,"REG_DWORD"
'其他程序从当前窗口的新选项卡打开连接
objShell.RegWrite "HKCU\Software\Microsoft\Internet
Explorer\TabbedBrowsing\ShortcutBehavior",0,"REG_DWORD"
Set objShell = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：获取IP/域名ping的结果信息
'程序输入：被ping的IP或者域名
'程序输出：True成功、False失败
'设计人员：LIUYI027
'设计时间：2011-12-13
'调用举例：Call GetPingResult("www.google.com")
'**************************************************************************
************************************************************
Function GetPingResult(pingedHost)
Set oPing = GetObject("winmgmts:").ExecQuery ("select * from
Win32_PingStatus where address = '" & pingedHost & "'")
For Each oRetStatus In oPing
If ISNULL(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
GetPingResult = False
Else
GetPingResult = True
End If
Next
Set oPing = Nothing
End Function
'**************************************************************************
************************************************************
'设计说明：使用邮件服务器发送邮件
'程序输入：参见函数定义，非常用函数，不做赘述
'程序输出：发出邮件
'设计人员：LIUYI027
'设计时间：2010-12-13
'调用举例：Call
SendMail(mailFrom,mailSmtp,sendUserName,sendUserPassword,mailTo,mailSubject
,mailBody,mailAttachment)
'**************************************************************************
************************************************************
Function
SendMail(mailFrom,mailSmtp,sendUserName,sendUserPassword,mailTo,mailSubject
,mailBody,mailAttachment)
Const conSendUsing
="http://schemas.microsoft.com/cdo/configuration/sendusing"
Const conServer
="http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const conServerPort
="http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const conConnectionTimeout
="http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
Const conAuthenticate
="http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Const conUsessl
="http://schemas.microsoft.com/cdo/configuration/smtpusessl"
Const conSendUserName
="http://schemas.microsoft.com/cdo/configuration/sendusername"
Const conSendPassword
="http://schemas.microsoft.com/cdo/configuration/sendpassword"
Const conPickupPackage
="http://schemas.microsoft.com/cdo/configuration/smtpserverpickupdirector
y"
Set objMessage = CreateObject("CDO.Message")
Set objConfig = CreateObject("CDO.Configuration")
Set Fields = objConfig.Fields
Set objMessage.Configuration = objConfig
With Fields
.Item(conSendUsing) = 1 '2为使用外部SMTP服务器,不要更改
.Item(conServer) = mailSmtp '改成可用的外部邮件服务器域名
.Item(conPickupPackage) = "C:\Inetpub\mailroot\pickup"
'如果使用外部smtp服务器，则不需要配置此值
.Item(conServerPort) = 25
'外部SMTP服务器端口,gmail使用465,其它一般使用25
.Item(conConnectionTimeout) = 10 '设定连接超时，单位秒
.Item(conUsessl) = False
'是否使用SSL安全套接字，gmail为true，其它一般false
.Item(conAuthenticate) = 1 '1为发送邮件需要认证,通常不要更改
.Item(conSendUserName) = sendUserName
.Item(conSendPassword) = sendUserPassword
.Update
End With
With objMessage
.To = Trim(mailTo) '改成接收者的邮件地址
.From = mailFrom
'改成发送人的邮件地址,要和上面的邮件系统相同
.Subject = Trim(mailSubject) '标题
.HTMLBody = "<html><head><meta http-equiv=""Content-Type""
content=""text/html; charset=Shift_JIS"" /></head>"&_
"<body>"&mailBody&"</body></html>" 'HTML邮件正文
.BodyPart.Charset = "Shift_JIS" '邮件编码
.HTMLBodyPart.Charset="Shift_JIS" '邮件HTML格式编码
If Trim(mailAttachment) <> "" Then
.AddAttachment mailAttachment '邮件附件
End If
.Send
End With
Set objMessage = Nothing
Set objConfig = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：根据日期、时间和两组随机数生成相对较为唯一的字符串，常用于文件的
非覆盖保存
'程序输入：循环次数，对于输入错误的字符串，截取第一位转换为对应的ASCII数字
作为循环最大次数
'程序输出：日期、时间、随机数、随机数的拼接字符串如：20110107_161003_93778_
47149
'设计人员：LIUYI027
'设计时间：2011-01-07
'调用举例：Printer GenerateUniqueStr("30")
'**************************************************************************
*****************************************************
Public Function GenerateUniqueStr(p_circle)
If Trim(p_circle) = "" Then
p_circle = randomnumber.Value(11,99)
Else
If isNumeric(p_circle) = False Then
p_circle = ASC(Left(p_circle,1))
If p_circle < 11 Then
p_circle = p_circle + 11
End If
Else
p_circle = Trim(p_circle)
End If
End If
randomNo = randomnumber.Value(10,Abs(p_circle))
For i = 1 to randomNo
randomNum1 = randomnumber.Value(10000,99999)
randomNum2 = Int((99999-10000+1)*rnd+10000)
Next
GenerateUniqueStr =
FormatDate(Now,"yyyymmdd_hh24miss")&"_"&randomNum1&"_"&randomNum2
End Function
'**************************************************************************
*****************************************************
'设计说明：（模仿PL/SQL的to_char(日期)函数）把日期/时间值转化成指定格式的字
符串
'程序输入：日期（当前日期）
'程序输出：固定格式的日期：年格式YYYY，月MM，日DD，时HH，分mm，秒，SS
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：msgbox FormatDate(date&time,'yyyy-mm-dd')
'**************************************************************************
*****************************************************
Function FormatDate(p_date, p_format)
Set parts= CreateObject("Scripting.Dictionary")
parts("yyyy") = CStr(Year(p_date))
parts("yy") = Right(Year(p_date), 2)
parts("mm") = Lpad(Month(p_date), 2, "0")
parts("mi") = Lpad(Minute(p_date), 2, "0") '
设计原因，包含m的必须放在month之前
parts("m") = CStr(Month(p_date))
parts("dd") = Lpad(Day(p_date), 2, "0")
parts("d") = CStr(Day(p_date))
parts("hh24") = Lpad(Hour(p_date), 2, "0")
parts("ss") = Lpad(Second(p_date), 2, "0")
v_result = p_format
For Each part In parts
v_result = Replace(v_result, part, parts(part))
Next
FormatDate = v_result
Set parts = Nothing
End Function
'**************************************************************************
*****************************************************
'设计说明：（模仿PL/SQL同名函数）将p_str长度扩展到p_width，用p_filling从左
边循环填充，本函数不会截短p_str
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：msgbox Lpad(Second(p_date), 2, "0")
'**************************************************************************
*****************************************************
Function Lpad(p_str, p_width, p_filling)
Lpad = ExpandString(p_filling, p_width - Len(p_str)) & p_str
End Function
'**************************************************************************
*****************************************************
'设计说明：（模仿PL/SQL同名函数）将p_str长度扩展到p_width，用p_filling从左
边循环填充，本函数不会截短p_str
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：msgbox Lpad(Second(p_date), 2, "0")
'**************************************************************************
*****************************************************
Function Rpad(p_str, p_width, p_filling)
Rpad = p_str & ExpandString(p_filling, p_width - Len(p_str))
End Function
'**************************************************************************
*****************************************************
'设计说明：将p_str反复叠加，使其长度扩展（或缩小）到p_width
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：ExpandString("bye",7) 返回 byebyeb ； ExpandString("bye",2)返回
by
'**************************************************************************
*****************************************************
Private Function ExpandString(p_str, p_width)
Dim width0, repeat_times, reminder, i, result
If p_width <= 0 Then
ExpandString = ""
Exit Function
End If
width0 = Len(p_str)
repeat_times = p_width \ width0
reminder = p_width Mod width0
For i = 1 To repeat_times
result = result & p_str
Next
result = result & Left(p_str, reminder)
ExpandString = result
End Function
'**************************************************************************
*****************************************************
'设计说明：从p_str的右边去除to_trim中*包含*的字符
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：RReplaceExp("1234ABC5678","0123456789")返回"1234ABC"
'**************************************************************************
*****************************************************
Function RReplaceExp(p_str, to_Trim)
Dim s, c
s = p_str
Do While True
c = Right(s, 1)
If InStr(to_Trim, c) > 0 Then
s = Left(s, Len(s) - 1)
Else
Exit Do
End If
Loop
RReplaceExp = s
End Function
'**************************************************************************
*****************************************************
'设计说明：从p_str的左边去除to_trim中*包含*的字符
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：LReplaceExp("1234ABC5678","0123456789")返回"ABC5678"
'**************************************************************************
*****************************************************
Function LReplaceExp(p_str, to_Trim)
Dim s, c
s = p_str
Do While True
c = Left(s, 1)
If InStr(to_Trim, c) > 0 Then
s = Right(s, Len(s) - 1)
Else
Exit Do
End If
Loop
LReplaceExp = s
End Function
'**************************************************************************
*****************************************************
'设计说明：判断str是否匹配正则表达式pattern，可以指定是否严格匹配大小写
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：ismatch("hello","^h.*o$",true) 返回true
'**************************************************************************
*****************************************************
Function isMatch(str, pattern, caseStrict)
Dim regex
set regex = New RegExp ' 建立正则表达式。
regex.pattern = pattern ' 设置模式。
regex.ignoreCase = not caseStrict ' 设置是否区分大小写。
isMatch = regex.test(str) ' 执行搜索测试。
End Function
'**************************************************************************
*****************************************************
'设计说明：正则表达式替换
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：replaceReg("helloworld","[aeiou]","") 返回hllwrld
'**************************************************************************
*****************************************************
Function replaceReg(Str, pattern, replacement)
Dim regex
set regex = New RegExp
regex.pattern = pattern
regex.global = True
replaceReg=regex.replace(Str, replacement)
End Function
'**************************************************************************
*****************************************************
'设计说明：用str_array中的变量代替text中的相应位置的?（问号）
'程序输入：
'程序输出：
'设计人员：LIUYI027
'设计时间：2011-01-04
'调用举例：FormatString("hello ?, I am ?", array("vbs","gaoning")) 返回
hello vbs, I am gaoning
'**************************************************************************
*****************************************************
Function FormatString(text, str_array)
Dim texts, i, t, result
texts=split(text,"?")
i=-1
For each t in texts
If i=-1 Then
result=t
Else
result= result & str_array(i) & t
End If
i=i+1
Next
FormatString= result
End Function
'**************************************************************************
*****************************************************
'设计说明：简化ReportEvent的书写，引自Saffron框架
'程序输入：结果报告状态
'程序输出：结果报告
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：Report Pass
'**************************************************************************
*****************************************************
Public Function Report (status, objtype, text)
Reporter.Filter = rtEnableAll
Reporter.ReportEvent status, objtype, text
End Function
'**************************************************************************
*****************************************************
'设计说明：将字符串两端加上双引号，引自SAFFRON框架
'程序输入：字符串
'程序输出：加了引号的字符串
'设计人员：LIUYI027
'设计时间：2011-01-08
'调用举例：Quote("AAA")返回 "AAA"
'**************************************************************************
*****************************************************
Public Function Quote (txt)
Quote = chr(34) & txt & chr(34)
End Function
'**************************************************************************
*****************************************************
'设计说明：取字符或字符串在一个数组中的位置，引自SAFFRON框架
'程序输入：数组、字符串
'程序输出：位置序号
'设计人员：
'设计时间：2011-01-08
'调用举例：IndexOf(myArray,"something")
'**************************************************************************
*****************************************************
Public Function IndexOf (myArray, str)
val = -1
For i = 0 to UBound(myArray)
If myArray(i) = str Then
val = i
End If
Next
IndexOf = val
End Function
'**************************************************************************
************************************************************
'设计说明：
'
判断一般性的js层抛出的控制提示，根据用户选择如何做后续处理，请注意，该程序
只能用于预期之外的提示处理，预期之内必须自行判断
'
如果不关心页面提示信息是什么，只想把提示信息抓出来，那么匹配关键字输入空值
即可
'程序输入：
' respath------截图文件保存路径
'
judgeKeyWord------用于进行匹配的关键字信息，可用英文半角的逗号分隔，只有所
有关键都在页面找到才视为运行通过
' isExitRun-------对于匹配失败的情况，选择是否彻底退出运行
'程序输出：截图文件
'设计人员：LIUYI027
'设计时间：2011-12-05
'调用举例：Call JudgeErrorForDialog("D:\","请,登录","Y")
'**************************************************************************
************************************************************
Public Sub JudgeErrorForDialog(respath,judgeKeyWord,isExitRun)
On Error Resume Next
Set Wshshell = CreateObject("Wscript.Shell")
'判断用户传入参数
If Trim(judgeKeyWord) = "" Or judgeKeyWord is Null Then
theKeyArray =
"用户选择不做关键字匹配"&Replace(Date,"/","-")&"_"&Replace(Time,":","-"
)
emptyPara = True
End If
theKeyArray = Split(judgeKeyWord,",")
If Trim(Replace(isExitRun,"y","Y")) = "Y" Or isExitRun = True Then
isExitRun = True
ElseIf Trim(Replace(isExitRun,"n","N")) = "N" Or isExitRun = False Then
isExitRun = False
Else
isExitRun = True
Reporter.ReportEvent
micWarning,"请尽量使用【Y/N】来作为您参数","由于本次输入无效，程序将自
动选择在无法完全匹配的时候自动退出运行，请了解！"
End If
'初始化所有打开的IE，以便确认所有的弹出窗口都已经展现在页面上
Set BrowserObject = Description.Create()
BrowserObject("micclass").Value = "Browser"
Set WindowsBrowser = Desktop.ChildObjects(BrowserObject)
brNum = WindowsBrowser.Count
If brNum < 1 Then
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set Wshshell = Nothing
Exit Sub
Else
For bindex = 0 to brNum - 1
WindowsBrowser(bindex).Sync
Next
End If
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set DialogObject = Description.Create()
DialogObject("micclass").Value = "Dialog"
Set WindowsDialog = Desktop.ChildObjects(DialogObject)
dlNum = WindowsDialog.Count
If dlNum < 1 Then
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set Wshshell = Nothing
If emptyPara = True Then
Reporter.ReportEvent
micPass,"没有需要判断的对象","提交之后系统没有任何弹出的页面信息提示
！"
Else
Reporter.ReportEvent
micWarning,"没有需要判断的对象","提交之后系统没有任何弹出的页面信息提
示！"
End If
Exit Sub
End If
For dindex = 0 to dlNum - 1
dlTitle = WindowsDialog(dindex).GetROProperty("text")
nameByTime = GenerateUniqueStr(30)&".png"
fileName =
respath&Environment.Value("TestName")&"_"&Environment.Value("ActionName
")&"_"&nameByTime
'对于弹出的下载窗口，需要用单独的程序处理，错误判断中不做处理，直接关闭
If INStr(dlTitle,"下载") > 0 Or INStr(dlTitle,"安装") > 0 Or
INStr(dlTitle,"另存为") > 0 Or INStr(dlTitle,"保存为") > 0 Then
WindowsDialog(dindex).Close
End If
'Windows
GUI直接处理掉，不在判断范围之内，如果需要使用则请自行修改（注释掉）这一
段
Set Win32Object = Description.Create()
Win32Object("micclass").Value = "WinObject"
Set WindowsObject = WindowsDialog(dindex).ChildObjects(Win32Object)
woNum = WindowsObject.Count
If woNum > 0 Then
For windex = 0 to woNum - 1
winMessage = WindowsObject(windex).GetROProperty("text")
If Not Trim(winMessage) = "" Then
Reporter.ReportEvent
micDone,"程序不做匹配判断的提示信息：",winMessage
End If
Next
Wshshell.AppActivate(dlTitle)
Delay 100
WindowsDialog(dindex).CaptureBitmap fileName
Wshshell.AppActivate(dlTitle)
Delay 400
Wshshell.SendKeys "{ENTER}"
End If
Set WindowsObject = Nothing
Set Win32Object = Nothing
Next
'重新Count页面上的非下载窗口个数
Set WindowsDialog = Nothing
Set WindowsDialog = Desktop.ChildObjects(DialogObject)
diaNum = WindowsDialog.Count
maxCount = 0
For dlindex = 0 to diaNum - 1
dlTitle = WindowsDialog(dlindex).GetROProperty("text")
nameByTime = GenerateUniqueStr(30)&".png"
fileName =
respath&Environment.Value("TestName")&"_"&Environment.Value("ActionName
")&"_"&nameByTime
'对于弹出的信息提示窗口，需要获取其提示信息，以供后续选择处理方式
Set StaticObject = Description.Create()
StaticObject("micclass").Value = "Static"
Set WindowsStatic = WindowsDialog(dlindex).ChildObjects(StaticObject)
stNum = WindowsStatic.Count
For sindex = 0 to stNum - 1
disMessage = WindowsStatic(sindex).GetROProperty("text")
arrindex = 0
For arrindex = 0 To UBound(theKeyArray)
If INStr(disMessage,theKeyArray(arrindex)) > 0 Then
maxCount = maxCount + 1
Reporter.ReportEvent micDone,"关键字匹配成功","关键字【
"&theKeyArray(arrindex)&" 】匹配成功！"
End If
arrindex = arrindex + 1
Next
Next
Wshshell.AppActivate(dlTitle)
Delay 100
WindowsDialog(dlindex).CaptureBitmap fileName
Wshshell.AppActivate(dlTitle)
Delay 400
Wshshell.SendKeys "{ENTER}"
Next
If maxCount < UBound(theKeyArray) + 1 Then
Reporter.ReportEvent
micFail,"函数【JudgeErrorForDialog】关键字匹配失败","您需要匹配【
"&(UBound(theKeyArray) + 1)&" 】个关键字，页面上出现了【 "&maxCount&"
】个！"
If isExitRun = True Then
Set WindowsStatic = Nothing
Set StaticObject = Nothing
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
ExitRun
End If
Else
Reporter.ReportEvent
micPass,"函数【JudgeErrorForDialog】关键字匹配成功","您需要匹配【
"&(UBound(theKeyArray) + 1)&" 】个关键字，页面上出现了【 "&maxCount&"
】个！"
End If
Set WindowsStatic = Nothing
Set StaticObject = Nothing
Set WindowsDialog = Nothing
Set DialogObject = Nothing
Set Wshshell = Nothing
End Sub
'**************************************************************************
************************************************************
'设计说明：
'
页面抛出未封装的RuntimeExcptions，一般是应用出错或者环境异常所致，对于这种
情况程序直接截图之后退出运行，不可选择
'
不同系统使用开发的习惯有所不同，例如有使用WebTable存放错误信息，有使用页面
短文本结合Link详细文本的方式，请自主改造
'程序输入：
' respath------截图文件保存路径
'
myKeyWords------用于进行匹配的关键字信息，可用英文半角的逗号分隔，只要有任
意关键字在页面找到都视为发现异常，运行退出
'程序输出：截图文件
'设计人员：LIUYI027
'设计时间：2011-12-05
'调用举例：Call
JudgePageExceptions("D:\","Excetion,EXCEPTION,exception,ORA-,详细情况")
'**************************************************************************
************************************************************
Public Sub JudgePageExceptions(respath,myKeyWords)
On Error Resume Next
Set Wshshell = CreateObject("Wscript.Shell")
'因为一旦出错立刻停止运行，不会出现多次截图导致的文件名冲突，故文件名只赋
一次值
nameByTime = GenerateUniqueStr(30)&".png"
fileName =
respath&Environment.Value("TestName")&"_"&Environment.Value("ActionName")
&"_"&nameByTime
'如果输入为空，则组合一个不大可能出现的错误信息出来，想必不会哪个系统出这
种Exception的：）
If Trim(myKeyWords) = "" Or myKeyWords is Null Then
myKeyWords =
myKeyWords&"用户选择不做关键字匹配"&Replace(Date,"/","-")&"_"&Replace(T
ime,":","-")
End If
theKeyArray = Split(myKeyWord,",")
Set BrowserObj = Description.Create()
BrowserObj("micclass").Value = "Browser"
Set Win32Browser = Desktop.ChildObjects(BrowserObj)
brNum = Win32Browser.Count
If brNum < 1 Then
Set WindowsBrowser = Nothing
Set BrowserObject = Nothing
Set Wshshell = Nothing
Exit Sub
End If
For bindex = 0 to brNum - 1
Win32Browser(bindex).Sync
Set PageObj = Description.Create()
PageObj("micclass").value = "Page"
Set Win32Page = Win32Browser(bindex).ChildObjects(PageObj)
pgNum = Win32Page.Count
For pindex = 0 to pgNum - 1
Set FrameObj = Description.Create()
FrameObj("micclass").Value = "Frame"
Set Win32Frame = Win32Page(pindex).ChildObjects(FrameObj)
frNum = Win32Frame.Count
'对于页面上的出错信息，如果存在使用LINK链接的错误文本信息则点开并且截
图，链接名称为需要匹配的关键字之一
For findex = 0 to frNum - 1
Set LinkObj = Description.Create()
LinkObj("micclass").Value = "Link"
Set Win32Link = Win32Frame(findex).ChildObjects(LinkObj)
liNum = Win32Link.Count
'判断是数组中的元素多还是页面上的Link多，选择少的做循环外部驱动，这
样可以适当提高性能
If lindex < UBound(theKeyArray) + 1 Then
For lindex = 0 to liNum - 1
linkText = Win32Link(lindex).GetROProperty("text")
For aindex = 0 To UBound(theKeyArray)
theKeyWord = theKeyArray(aindex)
brTit = Win32Browser(bindex).GetROProperty("title")
If InStr(lindex,theKeyWord) > 0 Then
Win32Link(lindex).Click
Win32Browser(bindex).Sync
Wshshell.AppActivate(brTit)
Delay 100
Win32Browser(bindex).CaptureBitmap fileName
Reporter.ReportEvent
micFail,"
分享到：
发表评论
-
QTP访问DOM的方法
2011-04-19 11:34 1322QTP支持直接访问DOM（Document Object Mo ... -
QTP随笔集
2011-04-12 14:14 1086QTP随笔集 问题一：WinObject回放时无法识别 因 ... -
QTP对象识别机制
2011-04-12 14:12 1614QTP对象识别机制 (转 ... -
透析QTP自动化测试框架SAFFRON
2011-03-25 17:29 11961、为什么要使用框架？ 框架是一组自动化测试的规范、测试脚本 ... -
QTP对象参数化的几种方法
2011-03-25 17:07 1747以前查看过对象参数化的资料说SetTOProperty 方法可 ... -
自动化框架构思
2011-03-24 17:43 863★通过QTP现有的功能管理脚本,对象和数据的缺点 1.脚本文件 ... -
QTP常用VB函数
2011-03-24 17:42 1181Left 函数 返回 Variant (String)，其中包 ... -
The HTML DOM defines a standard way for accessing and manipulating HTML document
2011-03-24 17:42 606The HTML DOM defines a standard ... -
QTP常用函数一
2011-03-24 17:41 819''''''''''''''''''''''''''''''' ... -
QTP DataTable
2011-03-24 17:40 962DataTable是QTP整合的一种创建数据驱动，参数化测试的 ... -
QTP对象库
2011-03-24 17:40 1305Note1：对象库-Object Repository 所谓对 ... -
QTP插件破解
2011-03-24 17:39 906QTP插件破解方法 第一步：完成安装.net插件，这是，插件界 ... -
QTP运行过程中弹出无法识别对象和对象不唯一的解决方法
2011-03-24 17:39 2296问题一：Cannot Identify Obj ... -
描述性编程（descriptive programming） 1、descriptive programming概述 通 常情况下，当在录制一个操作时，QT
2011-03-24 17:39 842描述性编程（descriptive programming） ... -
QTP对象识别技术
2011-03-24 17:38 803'****************************** ... -
'******************************************************************************
2011-03-24 17:38 660'****************************** ...
相关推荐
QTP常用函数集合，直接使用Executefile引用到脚本即可
QTP常用函数 QTP截图函数 QTP时间处理函数
QTP常用函数.docx
QTP常用函数，如：Left 函数、Mid 函数、Len 函数等
常用QTP函数合集，样例内容如下： '有用的没用的都丢到一起，可能会有你想要的，原本是分为FileOper、DataOper、We bOper（基于SAFFRON）、Win32Oper和ErrorOper五个文件 '后面三个超级啰嗦超级长的废物可能别人用不...
QTp常用函数
介绍了qtp常用的函数及调用，十分实用，对初学者有很大帮助
QTP中自定义的常用函数,包括FTP,测试报告等
自动化测试工具QTP常用的VBS函数总结
1.富文本框对象的识别代码；2.获取页面所有多选框（其他对象同理）；3.设置对象；4.相对路径；5.键盘操作；6.增加同步点等
怎样使用脚本启动QTP应用，并打开一个新的测试
QTP Excel函数包含全部常用函数功能代码 QTP Excel函数 QTP Excel函数
做软件自动化测试的常用函数总结 GetCellData函数 作用:获取单元格的值 例: rowCount = Browser("xxx ").Page("xxx ").Frame("xxx").WebTable("xxx").RowCount For counter = 1 To rowCount
QTP中常用的VB函数 QTP中常用的VB函数
QTP中自定义的常用函数,包括FTP,测试报告等
QTP常用技巧应用 1、QTP的Action间的信息共享的4种方 2、TD与QTP连接 3、QTP读取Excel数据的方法 4、QTP连接数据库 5、QuickTest Plus小工具，大作用 6、基础知识 7、对象库和对象属性 8、文件、参数表和ACTION 9、...
qtp常用方法.txt QTP代码参考框架.txt QTP多种函数使用方法.doc QTP技术集锦.doc QTP识别和操作对象的原理.doc 1 自动化测试的实践-应用QTP测试框架.ppt 3 TD+QTP实用操作手册—银行付款实例讲解.ppt RegexTester....
QTP中常用的VB函数.doc