'Reference Google and MSDN Site
On Error resume Next
err.clear
Sub calendarExport
Dim objWord
Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim lngASC
Dim strASCII
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem
strSheet = "C:\Calendar.xls"
'Adjust the following number to be 1 less than the row number of the
'first body row
i = 3
'Initialize column letters with 64, so the first letter used will be A
lngASCII = 64
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Workbooks.Open(strSheet)
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True
'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count
'Iterate through items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm in itms
i = i + 1
' If i > 809 then
objExcelSheet.Range("H1") = (i-3)
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Start
If err.number = 0 then
If itm.Start <> "" Then objRange.Value = itm.Start
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.End
If err.number = 0 then
If itm.End <> "" Then objRange.Value = itm.End
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
On Error resume Next
strV = itm.CreationTime
If err.number = 0 then
If itm.CreationTime <> "" Then objRange.Value = itm.CreationTime
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Subject
If err.number = 0 then
If itm.Subject <> "" Then objRange.Value = itm.Subject
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Location
If err.number = 0 then
If itm.Location <> "" Then objRange.Value = itm.Location
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Categories
If err.number = 0 then
If itm.Categories <> "" Then objRange.Value = itm.Categories
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.IsRecurring
If err.number = 0 then
If itm.IsRecurring <> "" Then objRange.Value = itm.IsRecurring
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = 64
' End If
Next
objExcelBook.Save
objExcelBook.Close
End Sub
Call calendarExport
Wednesday, May 20, 2009
MS-Outlook COM: VBS to Delete old Calendar data
'Delete old calendar items in Outlook.
'Recurring items will not be deleted.
'Items with end date less than the mentioned, would be deleted.
On Error resume Next
err.clear
Public intDel
Public Action
Sub calendarDel()
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem
Action = InputBox("Thanks for Using Calender Items deletion tool, Enter 1 to continue")
If Action = 1 then
'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count
dtEnd = InputBox("Enter date in mm/dd/yyyy format")
intDel = 0
For Each itm in itms
i = i + 1
dtOrgEnd = itm.End
blFlagday = DateDiff("d", dtEnd,dtOrgEnd)
If blFlagday < 1 Then
If not(itm.IsRecurring) Then
itm.delete
intDel = intDel + 1
End If
intnotDel = intnotDel + 1
End If
Next
Else
MsgBox "Items not deleted"
End If
End Sub
'Procedure call to execute the calendar item delete function.
calendarDel()
' Notification on the number of calendar items deleted.
If Action = 1 then
msgbox "Number of calender items deleted = "& intDel
Else
msgbox "Number of calender items not deleted = "& intnotDel
End If
'Recurring items will not be deleted.
'Items with end date less than the mentioned, would be deleted.
On Error resume Next
err.clear
Public intDel
Public Action
Sub calendarDel()
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem
Action = InputBox("Thanks for Using Calender Items deletion tool, Enter 1 to continue")
If Action = 1 then
'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count
dtEnd = InputBox("Enter date in mm/dd/yyyy format")
intDel = 0
For Each itm in itms
i = i + 1
dtOrgEnd = itm.End
blFlagday = DateDiff("d", dtEnd,dtOrgEnd)
If blFlagday < 1 Then
If not(itm.IsRecurring) Then
itm.delete
intDel = intDel + 1
End If
intnotDel = intnotDel + 1
End If
Next
Else
MsgBox "Items not deleted"
End If
End Sub
'Procedure call to execute the calendar item delete function.
calendarDel()
' Notification on the number of calendar items deleted.
If Action = 1 then
msgbox "Number of calender items deleted = "& intDel
Else
msgbox "Number of calender items not deleted = "& intnotDel
End If
Wscript: Map Network drives
'VBS to connect and disconnect network drives.
'strPath and strDrive and the shared drive path and the drive letter to be mapped.
'Assumption is that the drive letter is valid and does not contain any drives mapped to it already.
'Commented line of code can be used to disconnet the mapped network drive.
Set objNetwork = CreateObject("Wscript.Network")
strPath = "\\test\test"
strDrive = "D:"
objNetwork.MapNetworkDrive strDrive ,strPath
'Use the code below to remove any network drive connections
'objNetwork.RemoveNetworkDrive strDrive
Set objNetwork = Nothing
'strPath and strDrive and the shared drive path and the drive letter to be mapped.
'Assumption is that the drive letter is valid and does not contain any drives mapped to it already.
'Commented line of code can be used to disconnet the mapped network drive.
Set objNetwork = CreateObject("Wscript.Network")
strPath = "\\test\test"
strDrive = "D:"
objNetwork.MapNetworkDrive strDrive ,strPath
'Use the code below to remove any network drive connections
'objNetwork.RemoveNetworkDrive strDrive
Set objNetwork = Nothing
MS Outlook Objcet Model : Send Email with Attachments
Set myOLApp = CreateObject("Outlook.Application")
Set myNameSpace = myOLApp.GetNameSpace("MAPI")
Set olMail = myOLApp.CreateItem(olMailItem)
set WshShell = CreateObject("WScript.Shell")
attachFile = "C:\test.txt"
With olMail
.to =""
.Subject = "Test Mail from QTP with Attachments"
.Body = "This is mail"
.NoAging = True
.Display
End With
Set myAttach = olMail.Attachments
myAttach.Add(ResFile)
'To avoid the display of modal dialog when trying to send email, use shortcut key CTRL S'
WshShell.SendKeys "%{s}"
Set myAttachments = Nothing
Set olMail = Nothing
Set myOLApp = Nothing
Set myNameSpace = myOLApp.GetNameSpace("MAPI")
Set olMail = myOLApp.CreateItem(olMailItem)
set WshShell = CreateObject("WScript.Shell")
attachFile = "C:\test.txt"
With olMail
.to =""
.Subject = "Test Mail from QTP with Attachments"
.Body = "This is mail"
.NoAging = True
.Display
End With
Set myAttach = olMail.Attachments
myAttach.Add(ResFile)
'To avoid the display of modal dialog when trying to send email, use shortcut key CTRL S'
WshShell.SendKeys "%{s}"
Set myAttachments = Nothing
Set olMail = Nothing
Set myOLApp = Nothing
Excel COM : Delete Rows from Sheet
strDataFile = "(File Name with Full Path)"
strCurrentSheetName = "(Sheet Name or Index)"
Set ExcelObj = CreateObject("Excel.Application")
ExcelObj.Workbooks.Open strDataFile
'Delete the first row always as the row gets shifted by one when the previous row is deleted.
For intRow = 1 To 3
ExcelObj.ActiveWorkbook.Worksheets (strCurrentSheetName).Rows(1).Delete
ExcelObj.ActiveWorkbook.save
Cnt = ExcelObj.ActiveWorkbook.Worksheets (strCurrentSheetName).Rows.count
Next
ExcelObj.Workbooks.Close
Set ExcelObj = nothing
strCurrentSheetName = "(Sheet Name or Index)"
Set ExcelObj = CreateObject("Excel.Application")
ExcelObj.Workbooks.Open strDataFile
'Delete the first row always as the row gets shifted by one when the previous row is deleted.
For intRow = 1 To 3
ExcelObj.ActiveWorkbook.Worksheets (strCurrentSheetName).Rows(1).Delete
ExcelObj.ActiveWorkbook.save
Cnt = ExcelObj.ActiveWorkbook.Worksheets (strCurrentSheetName).Rows.count
Next
ExcelObj.Workbooks.Close
Set ExcelObj = nothing
Execute QTP Tests stored in QC through VBS file
Dim qtApp 'As QuickTest.Application ' Declare the Application object variable
Dim qtUpdateRunOptions 'As QuickTest.UpdateRunOptions ' Declare an Update Run Options object variable
Dim qtRunResultsOptions 'As QuickTest.RunResultsOptions ' Declare a Run Results Options object variable
Dim blsSupportsVerCtrl ' Declare a flag for indicating version control support
Dim td As New TDConnection
Dim tstMgr As TestSetTreeManager
Dim tsttr As TestSetFolder
Dim tsetFact As TestSetFactory
Dim tsetList as List
Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible
' Make changes in a test on Quality Center with version control
qtApp.TDConnection.Connect "http://tdserver/tdbin", _ "MY_DOMAIN", "My_Project", "UID", "Pwd", False ' Connect to Quality Center
' If connection is successful
If qtApp.TDConnection.IsConnected Then
blsSupportsVerCtrl = qtApp.TDConnection.SupportVersionControl
'Check whether the project supports vervion control
'Retrive all the Test from QC and Save them to Local Disk
Set tstMgr = td.TestSetTreeManager
Set tsttr = tstMgr.NodeByPath("Path\Test")
Set tsetFact = tsttr.TestSetFactory
Set tsetList = tsetFact.NewList("")
For Each tset in tsetList
qtApp.Open "[QualityCenter] Subject\tests\test1", False ' Open the test
If blsSupportsVerCtrl Then ' If the project supports version control
qtApp.Test.CheckOut ' Check out the test
End If
' Prepare the UpdateRunOptions object
Set qtUpdateRunOptions = CreateObject("QuickTest.UpdateRunOptions") ' Create the Update Run Options object
' Set the Update Run options: update the Active Screen and test object descriptions. Do not update checkpoint values
qtUpdateRunOptions.UpdateActiveScreen = True
qtUpdateRunOptions.UpdateCheckpoints = False
qtUpdateRunOptions.UpdateTestObjectDescriptions = True
' Prepare the RunResultsOptions object
Set qtRunResultsOptions = CreateObject("QuickTest.RunResultsOptions") ' Create the Run Results Options object
qtRunResultsOptions.ResultsLocation = "" ' Set a temporary results location
If blsSupportsVerCtrl And qtApp.Test.VerCtrlStatus = "CheckedOut" Then ' If the test is checked out
qtApp.Test.CheckIn ' Check it in
End If
Next
qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
MsgBox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.
End If
'Exit QuickTest
qtApp.Quit
Set qtApp = nothing
Dim qtUpdateRunOptions 'As QuickTest.UpdateRunOptions ' Declare an Update Run Options object variable
Dim qtRunResultsOptions 'As QuickTest.RunResultsOptions ' Declare a Run Results Options object variable
Dim blsSupportsVerCtrl ' Declare a flag for indicating version control support
Dim td As New TDConnection
Dim tstMgr As TestSetTreeManager
Dim tsttr As TestSetFolder
Dim tsetFact As TestSetFactory
Dim tsetList as List
Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible
' Make changes in a test on Quality Center with version control
qtApp.TDConnection.Connect "http://tdserver/tdbin", _ "MY_DOMAIN", "My_Project", "UID", "Pwd", False ' Connect to Quality Center
' If connection is successful
If qtApp.TDConnection.IsConnected Then
blsSupportsVerCtrl = qtApp.TDConnection.SupportVersionControl
'Check whether the project supports vervion control
'Retrive all the Test from QC and Save them to Local Disk
Set tstMgr = td.TestSetTreeManager
Set tsttr = tstMgr.NodeByPath("Path\Test")
Set tsetFact = tsttr.TestSetFactory
Set tsetList = tsetFact.NewList("")
For Each tset in tsetList
qtApp.Open "[QualityCenter] Subject\tests\test1", False ' Open the test
If blsSupportsVerCtrl Then ' If the project supports version control
qtApp.Test.CheckOut ' Check out the test
End If
' Prepare the UpdateRunOptions object
Set qtUpdateRunOptions = CreateObject("QuickTest.UpdateRunOptions") ' Create the Update Run Options object
' Set the Update Run options: update the Active Screen and test object descriptions. Do not update checkpoint values
qtUpdateRunOptions.UpdateActiveScreen = True
qtUpdateRunOptions.UpdateCheckpoints = False
qtUpdateRunOptions.UpdateTestObjectDescriptions = True
' Prepare the RunResultsOptions object
Set qtRunResultsOptions = CreateObject("QuickTest.RunResultsOptions") ' Create the Run Results Options object
qtRunResultsOptions.ResultsLocation = "
If blsSupportsVerCtrl And qtApp.Test.VerCtrlStatus = "CheckedOut" Then ' If the test is checked out
qtApp.Test.CheckIn ' Check it in
End If
Next
qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
MsgBox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.
End If
'Exit QuickTest
qtApp.Quit
Set qtApp = nothing
Friday, April 17, 2009
VBS - Sort Array
Dim A(10)
A(0) = ZZZZZ
A(1) = Abbbb
A(2) = AAAAAA
Public IsSort
Function IsSorted (Ar,sort_type)
IsSort = True
For i=0 To UBound(Ar)-1
If StrComp(Ar(i), Ar(i+1),sort_type) = 1 Then
IsSort = False
Exit Function
End If
Next
End Function
Call IsSorted(A,1)
MsgBox IsSort
A(0) = ZZZZZ
A(1) = Abbbb
A(2) = AAAAAA
Public IsSort
Function IsSorted (Ar,sort_type)
IsSort = True
For i=0 To UBound(Ar)-1
If StrComp(Ar(i), Ar(i+1),sort_type) = 1 Then
IsSort = False
Exit Function
End If
Next
End Function
Call IsSorted(A,1)
MsgBox IsSort
Wscript Usage - Map Network Drives
'VBS to connect and disconnect network drives.
'strPath and strDrive and the shared drive path and the drive letter to be mapped.
'Assumption is that the drive letter is valid and does not contain any drives mapped to it already.
'Commented line of code can be used to disconnet the mapped network drive.
'Date Created : 07/07/2007
Set objNetwork = CreateObject("Wscript.Network")
strPath = "\\test\test"
strDrive = "D:"
objNetwork.MapNetworkDrive strDrive ,strPath
'Use the code below to remove any network drive connections
'objNetwork.RemoveNetworkDrive strDrive
Set objNetwork = Nothing
'strPath and strDrive and the shared drive path and the drive letter to be mapped.
'Assumption is that the drive letter is valid and does not contain any drives mapped to it already.
'Commented line of code can be used to disconnet the mapped network drive.
'Date Created : 07/07/2007
Set objNetwork = CreateObject("Wscript.Network")
strPath = "\\test\test"
strDrive = "D:"
objNetwork.MapNetworkDrive strDrive ,strPath
'Use the code below to remove any network drive connections
'objNetwork.RemoveNetworkDrive strDrive
Set objNetwork = Nothing
ADO Usage in Excel
'Treat Excel like Database and retrieve data from it.
On Error Resume Next
'Const adOpenStatic = 3
'Const adLockOptimistic = 3
'Const adCmdText = &H0001
Set objConnection = CreateObject("ADODB.Connection")
'Set objRecordSet = CreateObject("ADODB.Recordset")
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\Documents and Settings\A032231\Desktop\Book2.xls;" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"
'objRecordset.Open "Select * FROM [Sheet1$]", _
' objConnection, adOpenStatic, adLockOptimistic, adCmdText
'strSearchCriteria = "Name = 'atl-fs-01'"
'objRecordSet.Find strSearchCriteria
'objRecordset.Close
'objConnection.Close
sql="Select * FROM [Sheet1$]"
set rs=objConnection.execute(sql)
i=0
'Get the row count from the values retrieved from the database
iRowCount = 0
Do While Not rs.EOF
iRowCount = iRowCount + 1
rs.MoveNext
Loop
If iRowCount = 0 then
MsgBox "No rows found"
else
fldCnt= rs.fields.count
rs.MoveFirst
Do While Not rs.EOF
For j= 0 To fldCnt-1
GData(j) = trim(rs.Fields(j).Value)
MsgBox GData(j)
Next
'Navigating to the next row in the database result set.
rs.MoveNext
Loop
'Close the Database Connection
objConnection.close
End If
On Error Resume Next
'Const adOpenStatic = 3
'Const adLockOptimistic = 3
'Const adCmdText = &H0001
Set objConnection = CreateObject("ADODB.Connection")
'Set objRecordSet = CreateObject("ADODB.Recordset")
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\Documents and Settings\A032231\Desktop\Book2.xls;" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"
'objRecordset.Open "Select * FROM [Sheet1$]", _
' objConnection, adOpenStatic, adLockOptimistic, adCmdText
'strSearchCriteria = "Name = 'atl-fs-01'"
'objRecordSet.Find strSearchCriteria
'objRecordset.Close
'objConnection.Close
sql="Select * FROM [Sheet1$]"
set rs=objConnection.execute(sql)
i=0
'Get the row count from the values retrieved from the database
iRowCount = 0
Do While Not rs.EOF
iRowCount = iRowCount + 1
rs.MoveNext
Loop
If iRowCount = 0 then
MsgBox "No rows found"
else
fldCnt= rs.fields.count
rs.MoveFirst
Do While Not rs.EOF
For j= 0 To fldCnt-1
GData(j) = trim(rs.Fields(j).Value)
MsgBox GData(j)
Next
'Navigating to the next row in the database result set.
rs.MoveNext
Loop
'Close the Database Connection
objConnection.close
End If
IE DOM Usage
'Use IE DOM to create a IE obejct and login
Function Login()
Set IE = CreateObject ("InternetExplorer.Application")
IE.Visible = True
IE.Navigate2 URL
End Function
*********************************************************************
'Wait till the browser is busy with page loading, used for synchornization
Function bBusy()
Do
' wait(1)
Loop while IE.Busy = TRUE
End Function
Function Login()
Set IE = CreateObject ("InternetExplorer.Application")
IE.Visible = True
IE.Navigate2 URL
End Function
*********************************************************************
'Wait till the browser is busy with page loading, used for synchornization
Function bBusy()
Do
' wait(1)
Loop while IE.Busy = TRUE
End Function
OTA Usage:Retrieve defect Data
'Retreive Defect properties
Dim td
Dim bfact
Dim bList
Dim Sev(10000)
Dim Id(10000)
Dim openDate(10000)
Dim closeDate(10000)
'Connect to QC
Set td=createobject("TDApiOle80.TDConnection.1")
td.InitConnectionEx "http://qcbin/start_a.htm"
td.ConnectProjectEx "DEFAULT", "", "",""
'Retrieve all defects and display the summary of the defects.
Set bfact = td.BugFactory
Set bList = bfact.NewList("")
i = 0
For Each Bug In bList
intId = Bug.Field("BG_BUG_ID")
If intId = "4" Then
Id(i) = Bug.Field("BG_BUG_ID")
Sev(i) = Bug.Field("BG_SEVERITY")
openDate(i) = Bug.Field("BG_DETECTION_DATE")
closeDate(i) = Bug.Field("BG_CLOSING_DATE")
i = i + 1
End If
Next
td.DisconnectProject
td.ReleaseConnection
Set bList = Nothing
Set bfact = Nothing
Set td = Nothing
Dim td
Dim bfact
Dim bList
Dim Sev(10000)
Dim Id(10000)
Dim openDate(10000)
Dim closeDate(10000)
'Connect to QC
Set td=createobject("TDApiOle80.TDConnection.1")
td.InitConnectionEx "http://qcbin/start_a.htm"
td.ConnectProjectEx "DEFAULT", "", "",""
'Retrieve all defects and display the summary of the defects.
Set bfact = td.BugFactory
Set bList = bfact.NewList("")
i = 0
For Each Bug In bList
intId = Bug.Field("BG_BUG_ID")
If intId = "4" Then
Id(i) = Bug.Field("BG_BUG_ID")
Sev(i) = Bug.Field("BG_SEVERITY")
openDate(i) = Bug.Field("BG_DETECTION_DATE")
closeDate(i) = Bug.Field("BG_CLOSING_DATE")
i = i + 1
End If
Next
td.DisconnectProject
td.ReleaseConnection
Set bList = Nothing
Set bfact = Nothing
Set td = Nothing
ADO Usage Sample
'Function to connect and retrieve data from tables(from Oracle)
***************************************************************************
Call createDBCon()
Call execDB()
Call verifyDBdata()
Call closeDB()
***************************************************************************
strQuery ="Select * from"
Function createDBCon()
reporter.ReportEvent micDone,"Connecting to Database",""
Set dbCon = CreateObject("ADODB.Connection")
dbCon.Open("DSN=IORA0001;UID=TDAMGR;PWD=TDAMGR123#;DBQ=IORA0001;DBA=W;APA=T;EXC=F;FEN=T;QTO=F;FRC=10;FDL=10;LOB=T;RST=T;GDE=F;FRL=F;BAM=IfAllSuccessful;MTS=F;MDI=F;CSR=F;FWC=F;PFC=10;TLO=0;")
End Function
'**********************************************************
'Execute the query passed using the DB obj created previously
'**********************************************************
Function execDB()
iRowCount = 0
set rs=dbCon.execute(strQuery1)
Set rs = Nothing
End Function
Function closeDB()
reporter.ReportEvent micDone,"Closing Database Connection",""
dbCon.close
End Function
'**********************************************************
'verify the db data after the loader process with the intial values
'**********************************************************
Function verifyDBdata()
Dim index
Dim iRowCount
iRowCount =0
set rs=dbCon.execute(strQuery2)
fldCnt= rs.fields.count
Do While Not rs.EOF
For i= 0 To fldCnt-1
dbOutput(i) = trim(rs.Fields(i).Value)
iRowCount = iRowCount+1
Next
rs.MoveNext
Loop
End Function
'Refer to Useful Links section for more information
***************************************************************************
Call createDBCon()
Call execDB()
Call verifyDBdata()
Call closeDB()
***************************************************************************
strQuery ="Select * from
Function createDBCon()
reporter.ReportEvent micDone,"Connecting to Database",""
Set dbCon = CreateObject("ADODB.Connection")
dbCon.Open("DSN=IORA0001;UID=TDAMGR;PWD=TDAMGR123#;DBQ=IORA0001;DBA=W;APA=T;EXC=F;FEN=T;QTO=F;FRC=10;FDL=10;LOB=T;RST=T;GDE=F;FRL=F;BAM=IfAllSuccessful;MTS=F;MDI=F;CSR=F;FWC=F;PFC=10;TLO=0;")
End Function
'**********************************************************
'Execute the query passed using the DB obj created previously
'**********************************************************
Function execDB()
iRowCount = 0
set rs=dbCon.execute(strQuery1)
Set rs = Nothing
End Function
Function closeDB()
reporter.ReportEvent micDone,"Closing Database Connection",""
dbCon.close
End Function
'**********************************************************
'verify the db data after the loader process with the intial values
'**********************************************************
Function verifyDBdata()
Dim index
Dim iRowCount
iRowCount =0
set rs=dbCon.execute(strQuery2)
fldCnt= rs.fields.count
Do While Not rs.EOF
For i= 0 To fldCnt-1
dbOutput(i) = trim(rs.Fields(i).Value)
iRowCount = iRowCount+1
Next
rs.MoveNext
Loop
End Function
'Refer to Useful Links section for more information
Useful Mercury KB Article : 1
Problem ID: 33128
Product: QTP Version Not RelevantQTP 6.5QTP 8.0
Ext(s): Web
Topics: Application Error, Dr. Watson, GPF, Hang, Freeze, CrashRecognition and Interaction with Web Objects (DOM, HTML, etc.)Interaction with the System Environment
OS: Windows Platform Not Relevant
Creation Date: 27 Jul 2004
Last Modified Date:19 Aug 2007
Problem Description: System resources problems and errors occur while testing Web applications
Occasionally, some users testing Web applications experience erratic problems related to system resources that can only be recreated in their own environment. This is normally experienced on really long test runs that consume a lot of system resources and eventually produce strange and erratic behavior that can include:
· Random errors or warnings,
· Crashing of IE, Quicktest, other apps or Windows,
· Corrupted data tables, or
· Corrupt data entered into app under test.
Solution: Optimize the system environment and minimize IE periodically during the test run
First, try to optimize and simplify your system environment as much as possible (i.e., ensure a lot of free space on the C:\ drive, reinstall your Service Pack, run Windows Update, try the script on another workstation, unload all unnecessary add-ins and applications, run all resources from local hard drive, etc).
If the problems continue, minimizing and restoring the browser window from within the script may help. It has been found that minimizing, then restoring the browser window tends to free resources used by IEXPLORE.EXE (and possibly QTPro.exe). It should be noted that to do this on replay, calling the .Minimize method will not free the resources, but using device replay to click a position relative to the window (where the minimize button is) will. This method can be used to help prevent exhausting system resources on replay of demanding tests.
Note:The increase of memory usage with IEXPLORE.EXE can be seen without QuickTest Professional. When QuickTest Professional is used to replay against a Web application, the memory usage can increase at a faster rate.
The custom function below can be helpful in many cases. Note that this is provided to try but is not guaranteed to work in all situations.
1. Copy the function definition to a .vbs library file. For more information on working with a Function Library, refer to Problem ID 26025 - How to create a VBScript library file and Problem ID 22314 - How to load a VBScript library file for use with a script.
' ** Function Definition **Function FreeIEResources (BrowserTitleIn) dim WinObj, absx, absy, width1, obj Set WinObj = Description.Create() WinObj("title").Value = BrowserTitleIn WinObj("index").Value = 0 absx = Browser(WinObj).GetROProperty("abs_x") absy = Browser(WinObj).GetROProperty("abs_y") width1 = Browser(WinObj).GetROProperty("width") Set obj = CreateObject("Mercury.DeviceReplay") 'obj.MouseMove absx+width1-50,absy+10 'wait 1 obj.MouseClick absx+width1-50,absy+10, 0 ' <--- this line may need to be modified wait 1 Set obj = Nothing Window(WinObj).Restore wait 1 Set WinObj = NothingEnd Function
Note:This function is not part of QuickTest Professional. It is not guaranteed to work and is not supported by Mercury Customer Support. You are responsible for any and all modifications that may be required.
If the browser does not minimize and restore when you execute the function, you may need to adjust the coordinates used to find the browser's minimize button. The line that will need to be modified is indicated above. You can use the MouseMove method to test the coordinates. Only the part of the first argument (absx+width1-50) should need to be adjusted.
2. Load the .vbs function library for use with the script.
3. Call the function from within your script.
Example:dim BrowserTitleBrowserTitle = "Yahoo!.*"FreeIEResources (BrowserTitle)' ORFreeIEResources ("Google.*")
Note:A regular expression can be used to for the Browser title. For more information on using regular expressions, refer to Problem ID 6069 - How to use regular expressions (or wildcards).
Place a call to the function in your script well before you feel you may need to free system resources. For example, if you are running several loops, it could be placed at the end of each loop.
An example test script is attached. When you run the test script, you will need to have the Task Manager open to the Processes tab.
Product: QTP Version Not RelevantQTP 6.5QTP 8.0
Ext(s): Web
Topics: Application Error, Dr. Watson, GPF, Hang, Freeze, CrashRecognition and Interaction with Web Objects (DOM, HTML, etc.)Interaction with the System Environment
OS: Windows Platform Not Relevant
Creation Date: 27 Jul 2004
Last Modified Date:19 Aug 2007
Problem Description: System resources problems and errors occur while testing Web applications
Occasionally, some users testing Web applications experience erratic problems related to system resources that can only be recreated in their own environment. This is normally experienced on really long test runs that consume a lot of system resources and eventually produce strange and erratic behavior that can include:
· Random errors or warnings,
· Crashing of IE, Quicktest, other apps or Windows,
· Corrupted data tables, or
· Corrupt data entered into app under test.
Solution: Optimize the system environment and minimize IE periodically during the test run
First, try to optimize and simplify your system environment as much as possible (i.e., ensure a lot of free space on the C:\ drive, reinstall your Service Pack, run Windows Update, try the script on another workstation, unload all unnecessary add-ins and applications, run all resources from local hard drive, etc).
If the problems continue, minimizing and restoring the browser window from within the script may help. It has been found that minimizing, then restoring the browser window tends to free resources used by IEXPLORE.EXE (and possibly QTPro.exe). It should be noted that to do this on replay, calling the .Minimize method will not free the resources, but using device replay to click a position relative to the window (where the minimize button is) will. This method can be used to help prevent exhausting system resources on replay of demanding tests.
Note:The increase of memory usage with IEXPLORE.EXE can be seen without QuickTest Professional. When QuickTest Professional is used to replay against a Web application, the memory usage can increase at a faster rate.
The custom function below can be helpful in many cases. Note that this is provided to try but is not guaranteed to work in all situations.
1. Copy the function definition to a .vbs library file. For more information on working with a Function Library, refer to Problem ID 26025 - How to create a VBScript library file and Problem ID 22314 - How to load a VBScript library file for use with a script.
' ** Function Definition **Function FreeIEResources (BrowserTitleIn) dim WinObj, absx, absy, width1, obj Set WinObj = Description.Create() WinObj("title").Value = BrowserTitleIn WinObj("index").Value = 0 absx = Browser(WinObj).GetROProperty("abs_x") absy = Browser(WinObj).GetROProperty("abs_y") width1 = Browser(WinObj).GetROProperty("width") Set obj = CreateObject("Mercury.DeviceReplay") 'obj.MouseMove absx+width1-50,absy+10 'wait 1 obj.MouseClick absx+width1-50,absy+10, 0 ' <--- this line may need to be modified wait 1 Set obj = Nothing Window(WinObj).Restore wait 1 Set WinObj = NothingEnd Function
Note:This function is not part of QuickTest Professional. It is not guaranteed to work and is not supported by Mercury Customer Support. You are responsible for any and all modifications that may be required.
If the browser does not minimize and restore when you execute the function, you may need to adjust the coordinates used to find the browser's minimize button. The line that will need to be modified is indicated above. You can use the MouseMove method to test the coordinates. Only the part of the first argument (absx+width1-50) should need to be adjusted.
2. Load the .vbs function library for use with the script.
3. Call the function from within your script.
Example:dim BrowserTitleBrowserTitle = "Yahoo!.*"FreeIEResources (BrowserTitle)' ORFreeIEResources ("Google.*")
Note:A regular expression can be used to for the Browser title. For more information on using regular expressions, refer to Problem ID 6069 - How to use regular expressions (or wildcards).
Place a call to the function in your script well before you feel you may need to free system resources. For example, if you are running several loops, it could be placed at the end of each loop.
An example test script is attached. When you run the test script, you will need to have the Task Manager open to the Processes tab.
Mercury Encrypter Object
Set enc=CreateObject("Mercury.Encrypter")
Msgbox enc.EnCrypt ("Automation")
Set enc=Nothing
OTA : Test Case Upload in QC
Public oWorkbook
Public oSheet
Public sWorkbook
Public intShtCnt
Public wrkbk
Public intArrCnt
Public wrkbk1
Public strTestCaseDescription
Public strDesSteps(10)
Public StrExpRes(10)
Public strStepCnt(10)
Public iRowCnt2
Public iRowCnt1
Public strExcelPath
Public strTestCaseName
Public strConfg(10)
Public td
Public tf
Public tstCase
Public dsf
Public ds
iRowCnt1 = 2
iRowCnt2 = 8
'*****************************************************************************************************
' Create the Excel Object required for reference
'*****************************************************************************************************'
public Function create()
Set app = createobject ("Excel.Application")
Set create = app
End Function
'*****************************************************************************************************
' Open the Excel File using the object created
'*****************************************************************************************************'
Public Function open()
Set wrkbk = create.Workbooks.Open(strExcelPath)
Set oSheet = wrkbk.WorkSheets
Set open = wrkbk
Set oSheet = Nothing
Set wrkbk = Nothing
End Function
'*****************************************************************************************************
'Kill all the open Excel Process
'*****************************************************************************************************'
Public Function Kill_Executable(Exe_Name)
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '"&Exe_Name&"'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Set colProcessList = Nothing
Set objWMIService = Nothing
End Function
'*****************************************************************************************************
'Terminate all the object created
'*****************************************************************************************************'
Public Function Class_Terminate()
Set app = Nothing
Set oSht = Nothing
Set oSheet = Nothing
Set wrkbk = Nothing
Call Kill_Executable("EXCEL.EXE")
End Function
'*****************************************************************************************************
'Read data from excel file and create an input array with all expected results
'*****************************************************************************************************'
Public Function readFromExcel()
strExcelPath = strConfg(5)
intArrCnt = 0
Dim strStepValue
Set oSht = open.Sheets(2)
strTestCaseName = (oSht.Cells(iRowCnt1,2))
Do while strTestCaseName <> ""
strTestCaseDescription = (oSht.Cells(3,2))
strTestCasePath = (oSht.Cells(4,2))
strStepValue = (oSht.Cells(iRowCnt2,1))
Do while strStepValue <> ""
strStepCnt(intArrCnt) = (oSht.Cells(iRowCnt2,1))
strDesSteps(intArrCnt) = (oSht.Cells(iRowCnt2,2))
StrExpRes(intArrCnt) = (oSht.Cells(iRowCnt2,3))
iRowCnt2 = iRowCnt2 + 1
intArrCnt = intArrCnt + 1
strStepValue = (oSht.Cells(iRowCnt2,1))
Loop
Set oSht = Nothing
Exit Do
Loop
End Function
'*****************************************************************************************************
'Read data from text file regarding the QC URL and Login Details and Excel Folder Path
'*****************************************************************************************************'
Function readTextFile()
Const ForReading = 1
Dim i
Dim strTextArr
i = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
("c:\testTq.txt", ForReading)
Do Until objTextFile.AtEndOfStream
strTextVal = objTextFile.Readline
strTextArr = Split(strTextVal,"=")
strConfg(i) = trim(strTextArr(1))
i = i + 1
Loop
End Function
'*****************************************************************************************************
'Upload the array elemenrts obtained from the Excel into the Quality Center.
'*****************************************************************************************************'
Function uploadQC()
Set td=createobject("TDApiOle80.TDConnection.1")
td.InitConnectionEx strConfg(0)
td.ConnectProjectEx strConfg(1),strConfg(2),strConfg(3),strConfg(4)
Set tstMgr = td.TreeManager
Set tsttr = tstMgr.NodeByPath(strTestCasePath)
'Creste testFactory object
Set tsetFact = tsttr.TestFactory
'Create new test with the sheet name
Set tstCase = tsetFact.AddItem(strTestCaseName)
tsetFact.Field("TS_DESCRIPTION") = strTestCaseDescription
'Post the new test case
tstCase.Post
'Create design steps factory object
Set dsf = tstCase.DesignStepFactory
'Iterate for the number of steps in the excel sheet
For m = 1 to intArrCnt-1
'Add individual steps into design steps along with step number, step description and expected result
Set ds = dsf.AddItem(Null)
ds.Field("DS_STEP_NAME") = strStepCnt(m)
ds.Field("DS_DESCRIPTION") =strDesSteps(m)
ds.Field("DS_EXPECTED") = StrExpRes(m)
ds.Post
Next
End Function
'*****************************************************************************************************
'Function Calls to Upload manual test cases from excel into QC
'*****************************************************************************************************'
Call readTextFile()
Call Class_Terminate()
Call readFromExcel()
Call Class_Terminate()
Call uploadQC()
Public oSheet
Public sWorkbook
Public intShtCnt
Public wrkbk
Public intArrCnt
Public wrkbk1
Public strTestCaseDescription
Public strDesSteps(10)
Public StrExpRes(10)
Public strStepCnt(10)
Public iRowCnt2
Public iRowCnt1
Public strExcelPath
Public strTestCaseName
Public strConfg(10)
Public td
Public tf
Public tstCase
Public dsf
Public ds
iRowCnt1 = 2
iRowCnt2 = 8
'*****************************************************************************************************
' Create the Excel Object required for reference
'*****************************************************************************************************'
public Function create()
Set app = createobject ("Excel.Application")
Set create = app
End Function
'*****************************************************************************************************
' Open the Excel File using the object created
'*****************************************************************************************************'
Public Function open()
Set wrkbk = create.Workbooks.Open(strExcelPath)
Set oSheet = wrkbk.WorkSheets
Set open = wrkbk
Set oSheet = Nothing
Set wrkbk = Nothing
End Function
'*****************************************************************************************************
'Kill all the open Excel Process
'*****************************************************************************************************'
Public Function Kill_Executable(Exe_Name)
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '"&Exe_Name&"'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Set colProcessList = Nothing
Set objWMIService = Nothing
End Function
'*****************************************************************************************************
'Terminate all the object created
'*****************************************************************************************************'
Public Function Class_Terminate()
Set app = Nothing
Set oSht = Nothing
Set oSheet = Nothing
Set wrkbk = Nothing
Call Kill_Executable("EXCEL.EXE")
End Function
'*****************************************************************************************************
'Read data from excel file and create an input array with all expected results
'*****************************************************************************************************'
Public Function readFromExcel()
strExcelPath = strConfg(5)
intArrCnt = 0
Dim strStepValue
Set oSht = open.Sheets(2)
strTestCaseName = (oSht.Cells(iRowCnt1,2))
Do while strTestCaseName <> ""
strTestCaseDescription = (oSht.Cells(3,2))
strTestCasePath = (oSht.Cells(4,2))
strStepValue = (oSht.Cells(iRowCnt2,1))
Do while strStepValue <> ""
strStepCnt(intArrCnt) = (oSht.Cells(iRowCnt2,1))
strDesSteps(intArrCnt) = (oSht.Cells(iRowCnt2,2))
StrExpRes(intArrCnt) = (oSht.Cells(iRowCnt2,3))
iRowCnt2 = iRowCnt2 + 1
intArrCnt = intArrCnt + 1
strStepValue = (oSht.Cells(iRowCnt2,1))
Loop
Set oSht = Nothing
Exit Do
Loop
End Function
'*****************************************************************************************************
'Read data from text file regarding the QC URL and Login Details and Excel Folder Path
'*****************************************************************************************************'
Function readTextFile()
Const ForReading = 1
Dim i
Dim strTextArr
i = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
("c:\testTq.txt", ForReading)
Do Until objTextFile.AtEndOfStream
strTextVal = objTextFile.Readline
strTextArr = Split(strTextVal,"=")
strConfg(i) = trim(strTextArr(1))
i = i + 1
Loop
End Function
'*****************************************************************************************************
'Upload the array elemenrts obtained from the Excel into the Quality Center.
'*****************************************************************************************************'
Function uploadQC()
Set td=createobject("TDApiOle80.TDConnection.1")
td.InitConnectionEx strConfg(0)
td.ConnectProjectEx strConfg(1),strConfg(2),strConfg(3),strConfg(4)
Set tstMgr = td.TreeManager
Set tsttr = tstMgr.NodeByPath(strTestCasePath)
'Creste testFactory object
Set tsetFact = tsttr.TestFactory
'Create new test with the sheet name
Set tstCase = tsetFact.AddItem(strTestCaseName)
tsetFact.Field("TS_DESCRIPTION") = strTestCaseDescription
'Post the new test case
tstCase.Post
'Create design steps factory object
Set dsf = tstCase.DesignStepFactory
'Iterate for the number of steps in the excel sheet
For m = 1 to intArrCnt-1
'Add individual steps into design steps along with step number, step description and expected result
Set ds = dsf.AddItem(Null)
ds.Field("DS_STEP_NAME") = strStepCnt(m)
ds.Field("DS_DESCRIPTION") =strDesSteps(m)
ds.Field("DS_EXPECTED") = StrExpRes(m)
ds.Post
Next
End Function
'*****************************************************************************************************
'Function Calls to Upload manual test cases from excel into QC
'*****************************************************************************************************'
Call readTextFile()
Call Class_Terminate()
Call readFromExcel()
Call Class_Terminate()
Call uploadQC()
Subscribe to:
Posts (Atom)