Excel Screen Shot File:

'Option Explicit
Sub createxls()
Dim ibmCurrentTerminal As IbmTerminal
Dim ibmCurrentScreen As IbmScreen
Dim hiddenTextEntry As String
Dim returnValue As Integer
Dim timeout As Integer
Dim waitText As String
timeout = 15000
Set ibmCurrentTerminal = ThisFrame.SelectedView.control
Set ibmCurrentScreen = ibmCurrentTerminal.Screen

On Error Resume Next
Dim Root, Filepath, Imagepath, Objxl, iCountwb, wb, oSnapxl, i
Dim osnapsheet, osnaprows, wbs, usedrow, pasteAt
Root = "C:\Users\sunshine\Desktop\Data\"
Filepath = Root & "log.xlsx"
Imagepath = Root + "ReflectionScreen.bmp"
'MsgBox Filepath
'MsgBox Imagepath
Set Objxl = GetObject(, "Excel.Application")
'Gives runtime Error 429 if object not found
'On Error GoTo 0
If Err = 429 Then
MsgBox "Excel Not Running", vbInformation, "Excel.Status"
Set Objxl = CreateObject("Excel.Application")

Else

'MsgBox Objxl.workbooks.Count

Set snapxl = Nothing
For Each wb In Objxl.workbooks
'*********************************************8
If wb.Name = "log.xlsx" Then
'Set oSnapxl = Objxl
Set snapxl = wb
'Set osnapsheet = oSnapxl.worksheets(1)
Set osnapsheet = snapxl.worksheets(1)
Exit For
End If
Next
Dim snapxlvalue

MsgBox snapxl
'*********************************************8
End If
one = snapxl

'If snapxl Is Nothing Or snapxl = Empty Then
If IsEmpty(snapxl) Then
Set osnapwb = Objxl.workbooks.add()

osnapwb.Visible = True
'Objxl.Visible = True

Set osnapsheet = osnapwb.worksheets(1)


End If

'MsgBox snapxl

usedrow = osnapsheet.usedrange.rows.Count
lcol = 1
For Each shp In osnapsheet.Shapes
        If shp.BottomRightCell.column > lcol Then _
        lcol = shp.BottomRightCell.column
        lrow = shp.BottomRightCell.row
        'MsgBox lcol & lrow
       
       
        Next
       
        With osnapsheet.Pictures.Insert("C:\Users\sunshine\Desktop\Data\ReflectionScreen.bmp")
        With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 820
        .Height = 426
    End With
    .Left = osnapsheet.cells(lrow + 5, 3).Left
    .top = osnapsheet.cells(lrow + 5, 3).top
    .Placement = 1
    .PrintObject = True
End With

Objxl.DisplayAlerts = False
osnapsheet.SaveAs (Filepath)




'End If

End Sub


Sub main()

Dim ibmCurrentTerminal As IbmTerminal
Dim ibmCurrentScreen As IbmScreen
Dim hiddenTextEntry As String
Dim returnValue As Integer
Dim timeout As Integer
Dim waitText As String
timeout = 15000

Set ibmCurrentTerminal = ThisFrame.SelectedView.control
Set ibmCurrentScreen = ibmCurrentTerminal.Screen


createxls
'Openxls
 Wait 3000

ibmCurrentScreen.SendKeys "hi"
createxls

ibmCurrentScreen.SendKeys "bye"
createxlslast "C:\Users\sunshine\Desktop\Data\loglast.xlsx"



End Sub



'Option Explicit
Sub createxlslast(strfilepath2)
Dim ibmCurrentTerminal As IbmTerminal
Dim ibmCurrentScreen As IbmScreen
Dim hiddenTextEntry As String
Dim returnValue As Integer
Dim timeout As Integer
Dim waitText As String
timeout = 15000
Set ibmCurrentTerminal = ThisFrame.SelectedView.control
Set ibmCurrentScreen = ibmCurrentTerminal.Screen

On Error Resume Next
Dim Root, Filepath, Imagepath, Objxl, iCountwb, wb, oSnapxl, i
Dim osnapsheet, osnaprows, wbs, usedrow, pasteAt
Root = "C:\Users\sunshine\Desktop\Data\"
strfilepath2 = Root & "loglast.xlsx"
Imagepath = Root + "ReflectionScreen.bmp"
'MsgBox Filepath
'MsgBox Imagepath
Set Objxl = GetObject(, "Excel.Application")
'Gives runtime Error 429 if object not found
'On Error GoTo 0
If Err = 429 Then
MsgBox "Excel Not Running", vbInformation, "Excel.Status"
Set Objxl = CreateObject("Excel.Application")

Else

'MsgBox Objxl.workbooks.Count

Set snapxl = Nothing
For Each wb In Objxl.workbooks
'*********************************************8
If wb.Name = "log.xlsx" Then
'Set oSnapxl = Objxl
Set snapxl = wb
'Set osnapsheet = oSnapxl.worksheets(1)
Set osnapsheet = snapxl.worksheets(1)
Exit For
End If
Next
Dim snapxlvalue

MsgBox snapxl
'*********************************************8
End If
one = snapxl

'If snapxl Is Nothing Or snapxl = Empty Then
If IsEmpty(snapxl) Then
Set osnapwb = Objxl.workbooks.add()

'osnapwb.Visible = True
Objxl.Visible = True

Set osnapsheet = osnapwb.worksheets(1)


End If

'MsgBox snapxl

usedrow = osnapsheet.usedrange.rows.Count
lcol = 1
For Each shp In osnapsheet.Shapes
        If shp.BottomRightCell.column > lcol Then _
        lcol = shp.BottomRightCell.column
        lrow = shp.BottomRightCell.row
        'MsgBox lcol & lrow
       
       
        Next
       
        With osnapsheet.Pictures.Insert("C:\Users\sunshine\Desktop\Data\ReflectionScreen.bmp")
        With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 820
        .Height = 426
    End With
    .Left = osnapsheet.cells(lrow + 5, 3).Left
    .top = osnapsheet.cells(lrow + 5, 3).top
    .Placement = 1
    .PrintObject = True
End With

Objxl.DisplayAlerts = False
osnapsheet.SaveAs (strfilepath2)
 Objxl.Quit




'End If

End Sub

VBScript: Function Returning Array



Function Getdata()

Dim a()
strt = "sumit"
strt2 = "raut"
a = Array(strt, strt2)

Getdata = a()


End Function

Sub main()


Dim oExcel, oWB, oSheet, setVal
Set oExcel = CreateObject("Excel.Application")
Set oWB = oExcel.Workbooks.Open("D:\Macrowork\Call from Sub.xlsx")
Set oSheet = oWB.WorkSheets("data")
oExcel.Visible = True
Dim Arr1()

rowcount = oSheet.usedrange.rows.Count

For r = 2 To rowcount Step 1

Arr1 = Getdata
oSheet.cells(r, 4) = Arr1(0)
oSheet.cells(r, 5) = Arr1(1)

Next

oWB.Save
Set oExcel = Nothing

End Sub

MSWord: Posting Images in Word Document via Vbscript

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection

'Set objRang = objDoc.Range()
Set objShape = objDoc.inlineShapes

''Add Picture to word file
fname="C:\Users\Public\Pictures\Sample Pictures\Koala.jpg"
fname2="C:\Users\Public\Pictures\Sample Pictures\Tulips.jpg"
objShape.AddPicture (fname)
objWord.Selection.MoveDown 1,0
objWord.Selection.TypeParagraph()

objShape.AddPicture (fname2)
objWord.Selection.MoveDown 1,0
objWord.Selection.TypeParagraph()

''Save Word File
objDoc.saveas("C:\Users\sunshine\Desktop\Test.docx")

VBscript:Sorting Numbers in Descending Order

dim a
a=array(1,5,6,7,8,9,0)
ub=ubound(a)
lb=lbound(a)

For i=lb to ub-1 Step 1



   For j=lb+i  to ub  Step 1
        if a(i)<a(j) then
         temp=a(j)
         a(j)=a(i)
         a(i)=temp
        end if
    Next


Next


'Print Sorted Array

for i=lbound(a) to ubound(a) Step 1
msgbox a(i)

Next

Vbscript:Skipping Iteration in a loop

function writefail(r)
oSheet.cells(r,5).value="INVALID as P"

End function


Dim oExcel, oWB, oSheet, getVal
Set oExcel=CreateObject("Excel.Application")
Set oWB=oExcel.Workbooks.Open("C:\Users\sunshine\Desktop\Macro\Data.xlsx")
Set oSheet=oWB.WorkSheets("Sheet1")
oExcel.Visible=TRUE

for r =2 to 14

status=oSheet.cells(r,4).value

if status="P" then oSheet.cells(r,5).value="INVALID as P"

'if status="P" then writefail(r)
do

'if status="P" then _
'writefail(r)
'exit do



'if status="P" then _
'oSheet.cells(r,5).value="INVALID as P" exit do
'loop while false

if status="P" then exit do

if status<>"P" then _
oSheet.cells(r,6).value="V1"
oSheet.cells(r,7).value="V2"
'oSheet.cells(r,5).value="VALID"
exit do
'loop while false
loop while r<6

Next

oWB.save
set oExcel=nothing

QTP/UFT Fetching Sheet/Column Value from Excel Sheet

REM GetRowValue( login,username)

Flag   Username  Password
 Y      sumit          pwdsumit
 N      sagar           neha123

Sheetname:Login
Workbookname:Data.xlsx

O/P: REM GetRowValue( login,username)
=>sumit


Function GetRowValue(Sheetname,Columnname)

Dim Oexl,Owb,Ows1,ows2,Sheetnamev,Columnnamev

Sheetnamev=Sheetname
Columnnamev=Columnname
Set Oexl=createobject("Excel.Application")

Set Owb=Oexl.Workbooks.Open("C:\Users\Sunshine\Desktop\GmailMar\Data\Master.xlsx")

Owb.Activate
'Owb.
'headername=Inputbox("Enter Header")
Set ologin=Owb.Worksheets(Sheetnamev)

ologinrc=ologin.usedrange.rows.count
ologincc=ologin.usedrange.columns.count





For j=1 to ologincc
If  ologin.cells(1,j)=Columnnamev  Then

columnheaderpos=j
'msgbox columnnumber

Exit For
End If



Next


For r=2 to  ologinrc step 1

If ologin.cells(r,1)="Y" Then


REM first find header's location



data=ologin.cells(r,columnheaderpos)
'GetHederPos=data
msgbox data


Exit  For
End If
Next




Set Owb=nothing
Set Ologin=nothing
Set Owb=nothing

'msgbox j
End Function



'GetHederPos "Login","Username"

 GetHederPos "Login","Password"

QTP - Crypt Object

QTP - Crypt Object Examples
================================================


Dim pwd
pwd=sumit
epwd=crypt.Encrypt("pwd")
print epwd

Output:
51eeb9d7dc0bee3d2b1ec7ba
'