Handling multi-dimensional array in vbscript

Was trying to build excel data provider, which can be used for Test Complete and QTP scripts. Created a VBScript to keep all excel contents into a multi-dimensional array.

Problem
Declared array with lower limits and then used ReDim to fix with right count. But I was able to retrieve the data only upto the initial array size.

Solution:
Tried different ways. Then declared array without any size as given in below code.

Code:

'-------------------------------------------------------------------------
' File     :   ExcelReadByArrays.vbs
' Author    :   PalaniSelvam Thillaiappan
' Purpose   :   To read the given sheet contents .
'-------------------------------------------------------------------------
'' Usage
'' cscript D:\MyCode\qtp_uft\ExcelReadByArrays.vbs 
'' test data: D:\MyCode\qtp_uft\testMyApp_1.xlsx
'******** Variables Declaration

Dim gsExcelFile, giStartRow, giStartCol, giEndRow, giEndCol, giSheetIndex
Dim gsLogFile
Dim arrExcelData() 'as all Rows data
'''Dim arrExcelData(5, 5) 'as all Rows data


giSheetIndex = 1
gsExcelFile = "D:\MyCode\qtp_uft\testMyApp_1.xlsx"


'' Working fine, but array size should be given properly
ExcelDataRead gsExcelFile, giSheetIndex, arrExcelData
PrintArrays arrExcelData

'--------------------------------------
' Method    :   ExcelDataRead
' Author    :   PalaniSelvam Thillaiappan
' Purpose   :   Read all the contents from Excel sheet and write into log file
' Parameters:   sExcelFile - String, contains the Excel file
'      :  iSheetIndex - Integer, Value for Sheet Index
'--------------------------------------
Sub ExcelDataRead(sExcelFile, iSheetIndex, ByRef arrExcel)
 Dim sExcelPath 'As Variant  'Excel file
 '********** Excel object declaration **********'
  ' Excel Application object
 Dim objExcel 'As Excel.Application
 Dim objXLWorkbooks 'As Excel.Workbooks
 Dim objXLWorkbook 'As Excel.Workbook

 Dim WorkSheetCount 'As Variant  'Work sheets count in a excel
 Dim CurrentWorkSheet 'As Excel.Worksheet    ' Current worksheet
 Dim objCells 'As Excel.Range
 Dim objCurrentCell 'As Variant
 Dim objFont 'As Variant

 ' Result contents
 Dim sCellText 'As Variant
 Dim sFontName 'As Variant
 Dim sFontStyle 'As Variant
 Dim iFontSize 'As Variant
 Dim iCellTextColorIndex 'As Variant
 Dim iCellInteriorColorIndex 'As Variant
 Dim sResult 'As Variant
 Dim sChartFile 'As String


 ' Row and Col integer variables
 Dim iUsedRowsCount 'As Integer
 Dim iUsedColsCount 'As Integer
 Dim iTop, iLeft 'As Integer
 Dim iRow 'As Integer     'Row item
 Dim iCol 'As Integer     'Col item
 Dim iCurRow 'As Integer
 Dim iCurCol 'As Integer
 Dim arrColList 'As Array - Column Name

 If (sExcelFile = "") Then
   sExcelPath = "D:\MyCode\qtp_uft\testMyApp_1.xlsx"
 Else
   sExcelPath = sExcelFile
 End If

 If (iSheetIndex = "") Then
  iSheetIndex = 2
 End If

 Set objExcel = CreateObject("Excel.Application")
 objExcel.Workbooks.Open sExcelPath, False, True

 On Error Resume Next

 WorkSheetCount = objExcel.Worksheets.Count

 Set objXLWorkbook = objExcel.ActiveWorkbook
 'objXLWorkbook.RunAutoMacros

 Set CurrentWorkSheet = objExcel.ActiveWorkbook.Worksheets(iSheetIndex) 'iSheetIndex worksheet

 iUsedRowsCount = CurrentWorkSheet.UsedRange.Rows.Count
 iUsedColsCount = CurrentWorkSheet.UsedRange.Columns.Count
 iTop = CurrentWorkSheet.UsedRange.Row
 iLeft = CurrentWorkSheet.UsedRange.Column

 CurrentWorkSheet.UsedRange.Columns.AutoFit()
 ' Cells object
 CurrentWorkSheet.Cells.Activate
 
 ReDim Preserve arrExcel(iUsedRowsCount, iUsedColsCount)
    ''ReDim arrColList(iUsedColsCount)


 For iRow = iTop To iUsedRowsCount   '(iUsedRowsCount - 1)
 
   'Read All Columns
   For iCol = iLeft To iUsedColsCount  '(iUsedColsCount - 1)

     sResult = ""
     Set objCurrentCell = CurrentWorkSheet.Cells(iRow, iCol)
     sCellText = objCurrentCell.Text
     sResult = "Reading Cell {" & CStr(iRow) & ", " & CStr(iCol) & "}^" & sCellText & "^" 
     WScript.echo sResult
     Set objCurrentCell = Nothing
     arrExcel (iRow-1, iCol-1) = sCellText
   Next

 Next
  
 ' This will prevent Excel from prompting us to save the workbook.
 objExcel.ActiveWorkbook.Saved = True
 Set CurrentWorkSheet = Nothing

 'objExcel.Worksbooks.Close
 objExcel.Quit

 ''Set CurrentWorkSheet = Nothing
 Set objExcel = Nothing


 'MsgBox "Read Completed.", vbOKOnly, "Exec Over"
 Exit Sub

 ErrorHandler1:
 'MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
 'Err.Clear   ' Clear the error.

End Sub

'' To display given array
Sub PrintArrays( arrList)
'' To Print all list items
Dim aValue      'array item ==> dictionary
Dim aItem       'dictionaly item ==> key-pair value
Dim iRow
Dim iCol


     WScript.echo "Array Rows Count: ",UBound (arrList, 1)  '' First Array
     WScript.echo "Array Columns Count: ",UBound (arrList, 2) ''Second Array


    For iRow =LBound(arrList) to UBound (arrList)-1

       For iCol=LBound(arrList,2) to UBound (arrList,2)-1
         aValue = arrList(iRow, iCol)

         WScript.echo iRow, iCol, " Value:", aValue

        Next

    Next


End Sub

Class concept in VBScript

In VB, Classes can be created using Class Module. Basic Module files are used to have user-defined procedures and variables. Many of the VB Scripts are designed by structure programming.

Using VBScript, one can apply OOPs based scripting also. Initalizing code should be added in Class_Initialize procedure. Similarly terminating code should be added into Class_Terminate procedure. Below I've given a sample VBS code for class implementation.

Sample code from Net: VBScript Class to Send Mail With CDOSYS
Sample VBS code for CLASS implementation

''  UtilClass.vbs
' Purpose: To illustrate Class concept in VBScript

Class StringLib

 Private Sub Class_Initialize 
  ' Class initialization
  
   MsgBox "Initializing StringLib class"

 End Sub 

 Private Sub Class_Terminate 
  ' Class termination -end of life
    MsgBox "Terminating StringLib class"
 End Sub 

 ' Purpose   :   Checks the given file is avialable or not.
 Function FileExists(strPathName)
     Dim ObjFSO

     Set ObjFSO = CreateObject("Scripting.FileSystemObject")

     If ObjFSO.FileExists(strPathName) = False Then
       FileExists = -1
     Else
       FileExists = 0
     End If

     Set ObjFSO = Nothing
 End Function

 ' Purpose   :   To replace {dot} with {index}{dot} in the file name.
 Function ReplaceFileName(sFileName, iMySheetIndex)

     Dim RepChar, SearchChar

     SearchChar = "."    ' Search for ".".
     RepChar = CStr(iMySheetIndex) & SearchChar
     ReplaceFileName = Replace(sFileName, SearchChar, RepChar)

 End Function

End Class

'Using StringLib class
Dim sText
Dim sReplaced
Set libStr = New StringLib
sReplaced= libStr.ReplaceFileName ("c:\mytests.xls", 5)
MsgBox "Replaced Text: " & sReplaced
Set libStr = Nothing

Extract info from Logs

One of my projects used to update set of log files for each action and scheduled actions. Exceptions are logged in those log files. Log file size is maintained upto 5 MB. We are unable to get the proper logs, if scripts are running more than 15 minutes. Entire suite runs almost 75 hours continuously.

Many times, we were unable to re-look at the exceptions in the logs for particular test case failed time. I thought to develop a vbscript to capture the exceptions from log file for frequent intervals and then write into another text file. It can be used for manual testing too. Here I made two things. First is, script has to parse the log file for the given string. Second is, script should not update the log information, which is already available. I meant, the same information should not be added multiple times.

Code to take only unique info It returns the information as Array. Array size is determined in run-time.

 
'-------------------------------------------------------------------------
' Method    :   TrimArrayToExtract
' Author    :   T. Palani Selvam
' Purpose   :   Remove the array elements based on given info (sItemToCheck).
' Parameters:   arrInput - Array String, Contains logging message.
'  sItemToCheck - String, to check the element match. Last element in the text file
' Returns   :   String - Array. Returns remaining elements from the given array.
' Caller    :   - Nil
' Calls     :   - Nil
'-------------------------------------------------------------------------
Function TrimArrayToExtract (arrInput, sItemToCheck)
    Dim iArrItem
    Dim sTemp
    Dim arrOutput()
    
    iIndex=0
    If (IsNull(sItemToCheck) Or IsEmpty(sItemToCheck) Or (Trim(sItemToCheck)= "")) Then
     TrimArrayToExtract=arrInput
     Exit Function
    Else    
     If (IsArray(arrInput)) Then
        'If (Not (IsNull(arrInput) Or IsEmpty(arrInput)) And (UBound(arrInput)> 1)) Then
        If (Not (IsNull(arrInput) Or IsEmpty(arrInput) Or (UBound(arrInput)=0)) ) Then
         'WScript.Echo "ArrInput : " & arrInput
      For iArrItem=0 to UBound(arrInput)  ''-1
   ReDim Preserve arrOutput(iIndex)
   sTemp=arrInput(iArrItem)
   If (sTemp=sItemToCheck) Then
      iIndex=0
      Erase arrOutput
   Else
      arrOutput(iIndex)=sTemp
      iIndex=iIndex+1
   End If

      Next 
    End If
  End If
   End If
    
   TrimArrayToExtract=arrOutput
   
End Function

Code for Extracting the information from Log file It returns the information in Array.

 
'--------------------------------------
' Method    :   ExtractInfoFromLog
' Author    :   T. Palani Selvam
' Purpose   :   To extract the lines from a log file based on given info.
' Parameters:   sFileName - String, contains the log filename with full path.
'               sInfo2Extract - String, Info to search.
' Returns   :   Array of String
' Caller    :   - Nil
' Calls     :   - Nil
'--------------------------------------
Function ExtractInfoFromLog (sFileName, sInfo2Extract)

 Dim objFSO, objTextFile, sLine
 Dim iPos
 Dim arrExtract()
 Dim iLinesToDo, iArrIndex, iLimit
 
 Const ForReading=1
 Const NoOfLines=10

 
 iArrIndex=0
 iLinesToDo=0
 iLimit=1
 
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 If  objFSO.FileExists(sFileName) Then

   Set objTextFile = objFSO.OpenTextFile(sFileName, ForReading) 

   Do while Not objTextFile.AtEndOfStream
  sLine = objTextFile.ReadLine        
  'Wscript.Echo sLine
  If (iLinesToDo > 0) Then
   arrExtract(iArrIndex)=sLine   
   iLinesToDo=iLinesToDo-1
   iArrIndex=iArrIndex+1
  Else
   
   iLinesToDo=0
   iPos=InStr(sLine,sInfo2Extract)
   'WScript.Echo("iPos  " & CStr(iPos))
   If (iPos>0) Then
    'WScript.Echo("Entered into If loop to extract from line: " & sLine)

    '' iLimit = UBound (arrExtract) + NoOfLines
    iLimit = iLimit + NoOfLines
    ReDim Preserve arrExtract(iLimit)

    arrExtract(iArrIndex)=sLine   
    iLinesToDo=NoOfLines-1 
    iArrIndex=iArrIndex+1

   Else
    iLinesToDo=0

   End If
  End If
  
   Loop

 End If

 objTextFile.Close

 Set objTextFile = Nothing 
 Set objFSO = Nothing 
 
 ExtractInfoFromLog=arrExtract
End Function

Note: Few user-defined functions might be used.

Closing Excel instance by VBScript

We have a test suite for Excel plug-in. Silktest built-in function does not work for Excel 2007. It is working fine for Excel 2003. Silktest is unable to close the Excel 2007 instance. We used Taskkill to kill the excel. It has created few other issues. I was looking for alternative solution. So I decided to write a vb script and got success. I have given the code below.

VBS code - To close Excel

'-------------------------------------------------------------------------
' File     :   CloseExcel.vbs
' Author    :   Palani
' Purpose   :   To close the excel, if it is already opened.
'
'' Revision History:
''$Log: CloseExcel.vbs,v $
''
'-------------------------------------------------------------------------
'' Usage
'' cscript D:\rpm_scripts_palani\tools\CloseExcel.vbs
'' cscript CloseExcel.vbs


'******** Variables Declaration
Dim gsLogFile

'******** Function calls
call CloseExcelApps ()


'--------------------------------------
' Method    :   CloseExcelApps
' Author    :   T. Palani Selvam
' Purpose   :   Close Excel application.
' Parameters:   - Nil
' Returns   :   - Nil
' Caller    :   - Nil
' Calls     :   - Nil
'--------------------------------------
Sub CloseExcelApps()
Dim sExcelPath 'As Variant  'Excel file
'********** Excel object declaration **********'
' Excel Application object
Dim objExcel 'As Excel.Application
Dim objExcel2 'As Excel.Workbooks
Dim objXLWorkbook 'As Excel.Workbook


On Error Resume Next

Set objExcel = GetObject(,"Excel.Application")
If Not (IsNull(objExcel) Or IsEmpty(objExcel)) Then
WScript.Echo ("Excel application instance Exists..") 
'Set objXLWorkbook = objExcel.ActiveWorkbook

'You can set this property to True if you want to close a modified workbook 
'without either saving it or being prompted to save it.

objExcel.ActiveWorkbook.Saved = True
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit

'objExcel.Worksbooks.Close
'objExcel.Quit

Set objExcel = Nothing
Set objExcel2 = GetObject(,"Excel.Application")
If Not (IsNull(objExcel2) Or IsEmpty(objExcel2)) Then
Set objExcel2 = Nothing
WScript.Echo ("FAIL. Excel application is not closed properly.") 
Else 
WScript.Echo ("PASS. Successfully closed Excel application.") 
End If 
WScript.Echo ("End - Closing excel application instance.") 
else
WScript.Echo ("Excel application instance does not exist!....") 
End If
End Sub

Automating Windows/Unix/Linux Server calls by w3Sockets

Earlier I have written a post Expect-Automating Command line tools for Expect utility. Now we can access any server machines by using VBScript. Dimac Development has implemented a COM interface to connect through Telnet and made as freeware. You need to download w3Sockets Dll and register it using SocketReg.exe included in a zip file. It is similar to expect utility. You can verify each command and can change the execution flow based on console output. It is much useful for automated testing as well as server administration. Below I have given a sample code to start windows services.

w3Sockets Reference
w3Sockets - Download Page

To start servers on Windows/Unix/Linux Systems

 
'To start servers on Windows/Unix/Linux server
Dim w3sock

Set w3sock = CreateObject("socket.tcp")
With w3sock
    .timeout = 5000
    .DoTelnetEmulation = True
    .TelnetEmulation = "TTY"
    .Host = "myserver:23"
    .Open
    .WaitFor "login:"
 WScript.Echo .Buffer
    .SendLine "myloginid"
    .WaitFor "password:"
    .SendLine "Password12"
    .WaitFor ">"
    .SendLine "net start ""MyServer Manager"""
    .WaitFor ">"
 WScript.Echo .Buffer
    .SendLine "net start ""MYDB Repository"""
    .WaitFor ">"
 WScript.Echo .Buffer
    .Close
End With
Set w3sock = Nothing

Saving Clipboard contents as Image

Scenario 1:
Earlier I had a challenging task to automate SVG charts. There are two issues. Major issue is, Silktest does not identify SVG Chart as any object (custom/HtmlImage). Second one is taking Bitmap image for the chart. SVG chart gives the flexibility by 'Copy SVG' feature. Using this we can copy the chart image. It can be saved as text or Image file.

Scenario 2:
Last month, I have posted VBA - Extract Pictures from Excel . It works fine, if this VBA code is executed as Excel Macro. But the same code does not extract the image with the right quality, after running as VB Script. I got the problem, while saving/pasting the clipboard copy. I was forced to find a way to implement a method, to save clipboard image as a image file.

Solution:
IrfanView is a windows graphic viewer and it is a freeware utility. It can be used command-line utility. It has a command-line option to save the clipboard image as image file. You can save the image in many different formats.

Syntax to Convert clipboard image as image file:
/clippaste - paste image from the clipboard.

Below I have given the way to implement in VBScript and Silktest.
Silktest code:

[ ] // To save the image
[ ] SYS_Execute ("D:\autostuff\i_view32.exe /silent /clippaste /convert=D:\my_scripts\testdata\zsvg1.bmp")

VB Script code:

'-------------------------------------------------------------------------
' Method    :   CreateImageFromClipBoard
' Author    :   Palani Selvam
' Purpose   :   It gets the clipboard image and convert as a image file.
' Parameters:   FileName - String, contains the BMP file name
'        iIndex - Integer, contains the Worksheet index
' Returns   :   String. The replaced file name it gives.
' Caller    :   - Nil
' Calls     :   - Nil
'-------------------------------------------------------------------------
Sub CreateImageFromClipBoard(sFileName)

    Dim wshShell,ShellReturnCode, sCmdExec
    
  Set WshShell = WScript.CreateObject("WScript.Shell")
  sCmdExec = "D:\autostuff\i_view32.exe /silent /clippaste /convert="& sFileName 

  ShellReturnCode = WshShell.Run(sCmdExec, 1, True)  
    
End Sub

Modified VB Script code for VBA - Extract Pictures from Excel
Note: Few function calls are from my vbscript library.

'--------------------------------------
' Method    :   ReadExcel
' Author    :   T. Palani Selvam
' Purpose   :   Read all the contents from Excel sheet and write into log file
' Parameters:   sExcelFile - String, contains the Excel file
'      :  iSheetIndex - Integer, Value for Sheet Index
' Returns   :   - Nil
' Caller    :   - Nil
' Calls     :   - Nil
'--------------------------------------
Sub ReadExcel(sExcelFile, iSheetIndex)
 Dim sExcelPath 'As Variant  'Excel file
 '********** Excel object declaration **********'
  ' Excel Application object
 Dim objExcel 'As Excel.Application
 Dim objXLWorkbooks 'As Excel.Workbooks
 Dim objXLWorkbook 'As Excel.Workbook

 Dim WorkSheetCount 'As Variant  'Work sheets count in a excel
 Dim CurrentWorkSheet 'As Excel.Worksheet    ' Current worksheet
 Dim objCells 'As Excel.Range
 Dim objCurrentCell 'As Variant
 Dim objFont 'As Variant

 ' Result contents
 Dim sCellText 'As Variant
 Dim sFontName 'As Variant
 Dim sFontStyle 'As Variant
 Dim iFontSize 'As Variant
 Dim iCellTextColorIndex 'As Variant
 Dim iCellInteriorColorIndex 'As Variant
 Dim sResult 'As Variant
 Dim sChartFile 'As String


 ' Row and Col integer variables
 Dim iUsedRowsCount 'As Integer
 Dim iUsedColsCount 'As Integer
 Dim iTop, iLeft 'As Integer
 Dim iRow 'As Integer     'Row item
 Dim iCol 'As Integer     'Col item
 Dim iCurRow 'As Integer
 Dim iCurCol 'As Integer


 If (sExcelFile = "") Then
   sExcelPath = "D:\my_scripts\Basic Wks.xls"
 Else
   sExcelPath = sExcelFile
 End If

 If (iSheetIndex = "") Then
  iSheetIndex = 2
 End If


 Call FileDeleteAndCreate (gsLogFile)

 'XL file check
 If (FileExists(sExcelPath) <> 0) Then
  Call LogWrite (gsLogFile, "The Excel file " & Chr(34) & sExcelPath & Chr(34) & " does not exit!")
  Exit sub
 End If

 Set objExcel = CreateObject("Excel.Application")
 objExcel.Workbooks.Open sExcelPath, False, True

 On Error Resume Next

 Set objXLWorkbook = objExcel.ActiveWorkbook
 'objXLWorkbook.RunAutoMacros
 
 WorkSheetCount = objXLWorkbook.Worksheets.Count

 Set CurrentWorkSheet = objExcel.ActiveWorkbook.Worksheets(iSheetIndex) 'iSheetIndex worksheet

 iUsedRowsCount = CurrentWorkSheet.UsedRange.Rows.Count
 iUsedColsCount = CurrentWorkSheet.UsedRange.Columns.Count
 iTop = CurrentWorkSheet.UsedRange.Row
 iLeft = CurrentWorkSheet.UsedRange.Column

 ' Cells object
 CurrentWorkSheet.Cells.Activate


 For iRow = iTop To iUsedRowsCount-1   '(iUsedRowsCount - 1)
   'Read All rows
   For iCol = iLeft To iUsedColsCount  '(iUsedColsCount - 1)

     sResult = ""
     Set objCurrentCell = CurrentWorkSheet.Cells(iRow, iCol)
     sCellText = objCurrentCell.Text


     If ((sCellText = Empty)) Then


       sResult = "Reading Cell {" & CStr(iRow) & ", " & CStr(iCol) & "}^" &"  "& "^" & "  " & "^" & "  " & "^" & "  " & "^" & "  " & "^" & "  "

       Call LogWrite (gsLogFile, sResult)

     Else
       Set objFont = objCurrentCell.Font
       sFontName = objFont.Name
       sFontStyle = objFont.FontStyle
       iFontSize = objFont.Size
       iCellTextColorIndex = objFont.Color
       iCellInteriorColorIndex = objCurrentCell.Interior.ColorIndex



       If (sFontName = Empty) Then
         sFontName = "empty"
       End If
       If (sFontStyle = Empty) Then
         sFontStyle = "empty"
       End If
       If (iFontSize = Empty) Then
         iFontSize = "-99999999"
       End If
       If (iCellTextColorIndex = Empty) Then
         iCellTextColorIndex = "99999999"
       End If
       If (iCellInteriorColorIndex = Empty) Then
         iCellInteriorColorIndex = "99999999"
       End If


       sResult = "Reading Cell {" & CStr(iRow) & ", " & CStr(iCol) & "}^" & sCellText & "^" & CStr(iCellInteriorColorIndex) & "^" & sFontName & "^" & CStr(sFontStyle) & "^" & CStr(iFontSize) & "^" & CStr(iCellTextColorIndex)

       Call LogWrite (gsLogFile, sResult)

     End If

     Set objCurrentCell = Nothing


   Next

 Next
 'Get the Chart now
 'sChartFile = Replace (sExcelFile,".xls",".png")
 sChartFile = Replace (sExcelFile,".xls",".bmp")
 
  '*****************************
  ' Place for Chart creation
    objExcel.ScreenUpdating = False
    
  Dim iIndex,iPictureHeight,iPictureWidth,iShapeCount
  Dim aShape, aChart, aShapeChart, aChart1
  Dim sPictureShape, sChartName, sCurrentSheet
 
 
 'Set aWorkSheet = ActiveWorkbook.ActiveSheet
 
 sCurrentSheet = CurrentWorkSheet.Name
  
 For iIndex = 1 To CurrentWorkSheet.Shapes.Count
 
  Set aShape = CurrentWorkSheet.Shapes(iIndex)
  sPictureShape = aShape.Name    
  'Picture 1 Name,  13
  
  If Left(aShape.Name, 7) = "Picture" Then
   aShape.CopyPicture
   Call CreateImageFromClipBoard (sChartFile)
     
   ''objExcel.ScreenUpdating = True
   Exit For

  End If
 Next
 
 if FileExists(sChartFile)=0 Then
  Call LogWrite (gsLogFile, "Chart Image: " & sChartFile)
 End If
 
 ' This will prevent Excel from prompting us to save the workbook.
 objExcel.ActiveWorkbook.Saved = True
 Set CurrentWorkSheet = Nothing

 'objExcel.Worksbooks.Close
 objExcel.Quit

 ''Set CurrentWorkSheet = Nothing
 Set objExcel = Nothing

 'MsgBox "Read Completed.", vbOKOnly, "Exec Over"
 Exit Sub

 ErrorHandler1:
 'MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
 'Err.Clear   ' Clear the error.
End Sub

VBA - Extract Pictures from Excel

Last month, I have written Excel Automation Using VBScript. Today this post is to extract Pictures from Excel. Generally We can not use Export method for pictures. But we can use for Excel charts. I tried to extract our SVG chart image by macro and I succeed on it. I got help from Export pictures from Excel Below I've given the VBA Macro code.

VBA Macro - To extract Picture from Excel

Sub GetFirstPicture()

Dim sCurrPath As String
Dim aWorkSheet As Excel.Worksheet
Dim aShape As Excel.Shape
Dim aShapeChart As Excel.Shape
Dim aPicture As Variant
Dim aChart As Excel.Chart
Dim sCurrentSheet As String

Dim aImage As Variant
Dim iIndex As Integer
Dim iShapeCount As Integer

Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Dim sChartJpg As String
Dim sChartGif As String
Dim sChartBmp As String

'On Error GoTo ErrHandler
On Error Resume Next

Application.ScreenUpdating = False

sCurrPath = "D:\VB\MyTrials\ChartExpFromXL"
sChartJpg = "D:\VB\MyTrials\ChartExpFromXL.jpg"
sChartGif = "D:\VB\MyTrials\ChartExpFromXL.gif"
sChartBmp = "D:\VB\MyTrials\ChartExpFromXL.bmp"

Set aWorkSheet = ActiveWorkbook.ActiveSheet
sCurrentSheet = aWorkSheet.Name

'MsgBox CStr(msoTrue) + " value for MsoTrue"
' MsoTrue equals to -1
MsgBox "Shapes count " + CStr(aWorkSheet.Shapes.Count)
For iIndex = 1 To aWorkSheet.Shapes.Count

Set aShape = aWorkSheet.Shapes(iIndex)
MyPicture = aShape.Name
MsgBox aShape.Name + " Name, " + Str(aShape.Type)
'Picture 1 Name,  13
If Left(aShape.Name, 7) = "Picture" Then
With aShape
PicHeight = .Height
PicWidth = .Width
End With
'Set aChart = aWorkSheet.ChartObjects(1)
Set aChart = ActiveWorkbook.Charts.Add
ActiveWorkbook.ActiveChart.Location Where:=xlLocationAsObject, Name:=sCurrentSheet
iShapeCount = aWorkSheet.Shapes.Count
Set aShapeChart = aWorkSheet.Shapes(iShapeCount)
MyChart = aShapeChart.Name      '"Chart " & Str(aWorkSheet.Shapes.Count)

aShapeChart.Width = PicWidth
aShapeChart.Height = PicHeight


With aWorkSheet
aShape.Copy

With ActiveChart 'aChart
.ChartArea.Select
.Paste
End With

.ChartObjects(1).Chart.Export Filename:=sChartJpg, FilterName:="jpg", Interactive:=True
.ChartObjects(1).Chart.Export Filename:=sChartGif
.ChartObjects(1).Chart.Export Filename:=sCurrPath & ".png"
'Not working .ChartObjects(1).Chart.Export Filename:=sChartBmp, FilterName:="bmp"
aShapeChart.Cut
End With

Application.ScreenUpdating = True

MsgBox "Completed."
Exit Sub

End If

Next

MsgBox "Completed."
Exit Sub

ErrHandler:
MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description & " " & Err.Source
Err.Clear   ' Clear the error.
End Sub

Re-using VBS code

Last week, I wanted to call VBS file into another VBS file. I wanted similar way in other languages like below.
In C++ -> Header file -> include <*.h>
In VB -> Modules (*.bas)
In Java -> Packages -> import com.myLayer.*

Basically I wanted to make it as a library. I am writing the functions to get the data from Excel and PPT. I have to create separate VBS file for each requirement. Few functions are common for all the VBS files. I got a help from visualbasicscript site. Post: Include VBS file in other files

VBScript code - To Import VBS Library

 
'--------------------------------------
' Method    :   ImportVBSLibrary
' Author    :   T. Palani Selvam
' Purpose   :   To import all vbs code from library file.
' Parameters:   sFileName - String, contains the VBS functions
' Returns   :   VBS code
' Caller    :   - Nil
' Calls     :   - Nil
'--------------------------------------
Function ImportVBSLibrary(sFileName)
 Dim ObjFSO,ObjFile
 Set ObjFSO = CreateObject("Scripting.FileSystemObject")
 Set ObjFile=ObjFSO.OpenTextFile(sFilename,1)
 ImportVBSLibrary=ObjFile.ReadAll
 Set ObjFile = Nothing
 Set ObjFSO = Nothing
End Function

ExecuteGlobal ImportVBSLibrary("D:\myscripts\tools\pal_lib.vbs")

Excel Automation Using VBScript

Using VBScript, we can automate most of the Excel verification activities. In one project we can export reports to Excel. I have to verify the cell value, font color and Background color. It is difficult task to verify each cell property by any GUI testing tool. All tools are used to identify Excel Grid (Workbook) as Custom Object. I am using VBScript to read the excel contents. Another advantage, you can use the VBScript against different versions of Excel such as 2002, 2003 and 2007. But you need to change the code for Excel 2003 and 2007, if you have done by using GUI objects.

Below I put one Visual Basic script code. It reads the given excel file and put the details of each cell into a log file. Copy all contents from below textbox and save it as MyExcel.vbs and try to run this VBS file. You can run this script by using any GUI Testing tool. Command line call should be cscript MyExcel.vbs sExcelFile iStartRow iStartCol iEndRow iEndCol iSheetIndex

To Know more about this VBA Help, download help from this link Microsoft Office 2003 Editions: Excel VBA Language Reference

If you are unable to run any VBScript, See my earlier post Unable to run VBS or CScript in Windows XP .

VB Script to Read Excel Contents

 
' USAGE: MyExcel.vbs "D:\VB\Complex.xls" iStartRow iStartCol iEndRow iEndCol iSheetIndex
'cscript MyExcel.vbs "D:\VB\Complex.xls" 1 1 30 12 2

'******** Variables Declaration
' Files section
    'XLS File name
gsFile="D:\VB\Complex.xls"  'File with macros
gsLogFile="D:\VB\Results_vbs.log" 

Dim gsExcelFile, giStartRow, giStartCol, giEndRow, giEndCol, giSheetIndex
Dim gsResultsFile                      'Text file name
gsDirSeparator = "\"                         'Directory separator character


If WScript.Arguments.Count = 6 Then
 gsExcelFile = WScript.Arguments.Item(0)
 giStartRow = CInt (WScript.Arguments.Item(1))
 giStartCol = CInt (WScript.Arguments.Item(2))
 giEndRow = CInt (WScript.Arguments.Item (3))
 giEndCol = CInt (WScript.Arguments.Item (4))
 giSheetIndex = CInt (WScript.Arguments.Item (5))
  'To Read the Excel file
  'ReadExcel gsFile, 1, 1, 30, 12, 2
  'WScript.Echo "ReadExcel " , gsExcelFile, giStartRow, giStartCol, giEndRow, giEndCol, giSheetIndex
 ReadExcel gsExcelFile, giStartRow, giStartCol, giEndRow, giEndCol, giSheetIndex

Else
 'WScript.Echo "Usage: MyExcel.vbs sExcelFile iStartRow iStartCol iEndRow iEndCol iSheetIndex"
 'WScript.Quit
 ReadExcel gsFile, 1, 1, 30, 12, 2
End If

'ReadExcel gsFile, 1, 1, 30, 12, 2

'---------------------------------
' Method    :   ReadExcel
' Author    :   T. Palani Selvam
' Purpose   :   Reading Excel contents.
' Parameters:   - Nil
' Returns   :   - Nil
' Caller    :   - Nil
' Calls     :   - Nil

' Revision History:
'
' [No]  da-mon-year Name:    Action:
' [ 1]  07-Nov-2007 Palani   Created first version
'---------------------------------
Sub ReadExcel(sExcelFile, iStartRow, iStartCol, iEndRow, iEndCol, iSheetIndex)

'WScript.Echo "ReadExcel " , sExcelFile, iStartRow, iStartCol, iEndRow, iEndCol, iSheetIndex
 'ReadExcel(sExcelFile As Variant, iStartRow As Integer, iStartCol As Integer, iEndRow As Integer, iEndCol As Integer,iSheetIndex As Integer)

' Purpose: For Excel verification
' To Read the Excel and write into a file
' Each cell content
' Each cell - Foreground color, font name, font style, font size and Background color.


Dim sExcelPath 'As Variant  'Excel file

'********** Excel object declaration **********'
 ' Excel Application object
Dim objExcel 'As Excel.Application
Dim objXLWorkbooks 'As Excel.Workbooks
Dim objXLWorkbook 'As Excel.Workbook

Dim WorkSheetCount 'As Variant  'Work sheets count in a excel
Dim CurrentWorkSheet 'As Excel.Worksheet    ' Current worksheet
Dim objCells 'As Excel.Range
Dim objCurrentCell 'As Variant
Dim objFont 'As Variant

' Result contents
Dim sCellValue 'As Variant
Dim sShowCellValue 'As Variant
Dim sFontName 'As Variant
Dim sFontStyle 'As Variant
Dim iFontSize 'As Variant
Dim iBackColorIndex 'As Variant
Dim iForeColorIndex 'As Variant
Dim iBackColorIndex2 'As Variant
Dim iForeColorIndex2 'As Variant
Dim sResult 'As Variant


' Row and Col integer variables
Dim iUsedRowsCount 'As Integer
Dim iUsedColsCount 'As Integer
Dim iTop, iLeft 'As Integer
Dim iRow 'As Integer     'Row item
Dim iCol 'As Integer     'Col item
Dim iCurRow 'As Integer
Dim iCurCol 'As Integer


If (sExcelFile = "") Then    
    sExcelPath = "D:\VB\Contacts.xls"
Else
    sExcelPath = sExcelFile
End If

if (iSheetIndex = "") Then
  iSheetIndex =1
End If 


FileDeleteAndCreate (gsLogFile)

'XL file check
If (FileExists (sExcelPath) <> 0) Then
  LogWrite ("The Excel file " & Chr(34) & sExcelPath & Chr(34) & " does not exit!")
  'WScript.Echo "The Excel file, " & Chr(34) & sExcelPath & Chr(34) & " does not exit!"
  'WScript.Quit
Else
  LogWrite ("The XL file " & sExcelPath & " exists.")
End If

Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open sExcelPath, False, True
'WScript.Echo "Reading data from " & sExcelPath
' objExcel.ExecuteExcel4Macro

'On Error GoTo ErrorHandler1
On Error Resume Next


WorkSheetCount = objExcel.Worksheets.Count
'WScript.Echo "We have " & WorkSheetCount & " worksheets."
'Set objXLWorkbook = objExcel.Workbooks(1)
Set objXLWorkbook = objExcel.ActiveWorkbook
'objXLWorkbook.RunAutoMacros

Set CurrentWorkSheet = objExcel.ActiveWorkbook.Worksheets(iSheetIndex) 'iSheetIndex worksheet
'Set CurrentWorkSheet = objExcel.ActiveWorkbook.Worksheets(1) 'First worksheet
' CurrentWorkSheet = objExcel.Worksheets(1) 'First worksheet


iUsedRowsCount = iEndRow 'CurrentWorkSheet.UsedRange.Rows.Count
iUsedColsCount = iEndCol 'CurrentWorkSheet.UsedRange.Columns.Count
iTop = iStartRow 'CurrentWorkSheet.UsedRange.Row
iLeft = iStartCol 'CurrentWorkSheet.UsedRange.Column

' Cells object
CurrentWorkSheet.Cells.Activate

For iRow = iTop To iUsedRowsCount   '(iUsedRowsCount - 1)
    'Read All rows
    For iCol = iLeft To iUsedColsCount  '(iUsedColsCount - 1)
        'Read all Columns
        
        sResult = ""

        Set objCurrentCell = CurrentWorkSheet.Cells(iRow, iCol)
        sCellValue = objCurrentCell.Value
        
        'If ((sCellValue = empty) Or (sCellValue = "empty")) Then
        If ((sCellValue = empty)) Then
            sCellValue = "empty"
         Else
            Set objFont = objCurrentCell.Font
            sFontName = objFont.Name
            
            sFontStyle = objFont.FontStyle
            iFontSize = objFont.Size
            iForeColorIndex = objFont.Color
            iForeColorIndex2 = objFont.ColorIndex
            
            If (sFontName = Empty) Then
                sFontName = "empty"
            End If
            If (sFontStyle = Empty) Then
                sFontStyle = "empty"
            End If
            If (iFontSize = Empty) Then
                iFontSize = "-99999999"
            End If
            If (iForeColorIndex = Empty) Then
                iForeColorIndex = "99999999"
            End If
            If (iForeColorIndex2 = Empty) Then
                iForeColorIndex2 = "99999999"
            End If
            sResult = "Reading Cell {" & CStr(iRow) & "," & CStr(iCol) & "}," & sCellValue & "," & sFontName & "," & CStr(sFontStyle) & "," & CStr(iFontSize) & "," & CStr(iForeColorIndex) & "," & CStr(iForeColorIndex2)
            
            LogWrite (sResult)

        End If
         Set objCurrentCell = Nothing        
         
    Next
    
Next

' This will prevent Excel from prompting us to save the workbook.
objExcel.ActiveWorkbook.Saved = True
Set CurrentWorkSheet = Nothing

'objExcel.Worksbooks.Close
objExcel.Quit

''Set CurrentWorkSheet = Nothing
Set objExcel = Nothing

            
MsgBox "Read COmpleted.", vbOKOnly, "Exec Over"
Exit Sub

ErrorHandler1:
MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
Err.Clear   ' Clear the error.

End Sub

'---------------------------------
' Method    :   Logwrite
' Author    :   T. Palani Selvam
' Purpose   :   Append the given message into Log file.
' Parameters:   sMsg - String, Contains logging message.
' Returns   :   - Nil
' Caller    :   - Nil
' Calls     :   - Nil

' Revision History:
'
' [No]  da-mon-year Name:    Action:
' [ 1]  07-Nov-2007 Palani   Created first version
'---------------------------------
Sub LogWrite(sMsg)
 Const ForAppending = 8
 'FileName = "D:\VBs\Mysamples\1create.txt"

 Set objFSO = CreateObject("scripting.FileSystemObject")
 Set objTextFile = objFSO.OpenTextFile (gsLogFile, ForAppending, True)

  objTextFile.WriteLine date & " " & time & ": " & sMsg
 objTextFile.Close

 Set objTextFile = Nothing 
 Set objFSO = Nothing 
End Sub

'---------------------------------
' Method    :   FileExists
' Author    :   T. Palani Selvam
' Purpose   :   Checks the given file is avialable or not.
' Parameters:   - Nil
' Returns   :   - Returns As Boolean
' Caller    :   - Nil
' Calls     :   - Nil
'---------------------------------
Function FileExists(strPathName)
'return 0 if a file exists else -1
 Dim ObjFSO
 
 Set ObjFSO = CreateObject("Scripting.FileSystemObject")
 
 if ObjFSO.FileExists(strPathName) = False then
   FileExists = -1
 else
   FileExists = 0
 end If
 
 Set ObjFSO = Nothing
End Function

'---------------------------------
' Method    :   FileDeleteAndCreate
' Author    :   T. Palani Selvam
' Purpose   :   To delete the file if exists..
' Parameters:   - Nil
' Returns   :   - Returns As Boolean
' Caller    :   - Nil
' Calls     :   - Nil
'---------------------------------
Function FileDeleteAndCreate(strFileName)
 ' delete
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 
 On Error Resume Next
 Set objTextFile = objFSO.GetFile(strFileName)
 objTextFile.Delete
 
 Set objTextFile = objFSO.CreateTextFile(strFileName)
 
 objTextFile.Close
 Set objTextFile = Nothing 
 Set objFSO = Nothing 

End Function

'---------------------------------
' Method    :   Initialize
' Author    :   T. Palani Selvam
' Purpose   :   Initial actions & arrangements will be completed.
' Parameters:   - Nil
' Returns   :   - Nil
' Caller    :   - Nil
' Calls     :   - Nil
'---------------------------------
Sub Initialize()
 'CHECKING INPUT FILES ARE AVAILABLE OR NOT
    gsLogFile = App.Path & "\Results.log"
End Sub

VBScript - Passing CmdLine Arguments

I was searching on net, how to pass the command line arguments. It is possible. We can pass the command line arguments in VBScript. If you have worked with command-line tools, you are already familiar with the concept of arguments. Arguments can be divided as Named Arguments and UnNamed Arguments.

Named arguments
Named arguments are arguments that consist of two parts: a name and a value. The name must be prefaced with a forward slash, and a colon must separate the name from the value. The slash prefix and the colon separator are fixed and cannot be changed. See below Example.

RemoteServer.vbs /Host:AppSrv1 /App:Symantec /TimeLimit:2000
Item : Value
Host:AppSrv1
App:Symantec
TimeLimit:2000

UnNamed arguments
The WshUnnamed filtered collection contains the one unnamed argument. The WshUnnamed Count method and Length property return the number of filtered arguments in the WshUnnamed collection. Example is given below.

FormatMask.vbs "D:\VB\FormatMask\Complex.xls" 30 12
Item : Value
0 : D:\VB\FormatMask\Complex.xls
1 : 30
2 : 12

Source: Working with Command-Line Arguments

Code: Example of UnNamed arguments

 
If WScript.Arguments.Count = 3 Then
 ServerName = WScript.Arguments.Item(0)
 EventLog = WScript.Arguments.Item(1)
 EventID = WScript.Arguments.Item(2)
Else
 Wscript.Echo "Usage: GetEvents.vbs ServerName EventLog EventID"
 Wscript.Quit
End If

Code: Named arguments

 
Set colNamedArguments = WScript.Arguments.Named

strServer = colNamedArguments.Item("Server")
strPacketSize = colNamedArguments.Item("PacketSize")
strTimeout = colNamedArguments.Item("Timeout")
Wscript.Echo "Server Name: " & strServer
Wscript.Echo "Packet Size: " & strPacketSize
Wscript.Echo "Timeout (ms): " & strTimeout

VBScript - File Read and Write

I have developed few projects using Visual Basic. But I do not have much scripting in Visual Basic Script (VBS). In VB, the file handling functions are different than VBScript. We need to use FileSystemObject for file handling. Below I have given two code snippets to read and write into text files. This code can be used into Quick Test Professional also.

Reading a Text file

 
Const ForReading = 1, ForWriting = 2

FileName = "D:\VBs\Mysamples\1create.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")

If  objFSO.FileExists(FileName) Then

  Set objTextFile = objFSO.OpenTextFile(FileName, ForReading) 

  Do while Not objTextFile.AtEndOfStream
        sLine = objTextFile.ReadLine        
        Wscript.Echo sLine
  loop
 
End If

objTextFile.Close

Set objFile = Nothing 
Set objFSO = Nothing 

Writing to a Text file

 
Const ForAppending = 8
FileName = "D:\VB\Mysamples\1create.txt"

Set objFSO = CreateObject("scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile (FileName, ForAppending, True)

For iIndex=1 to 10
 objTextFile.WriteLine(iIndex)
Next

objTextFile.Close

Set objTextFile = Nothing 
Set objFSO = Nothing 

Convert Number to Word

In my first job, I needed to have a function to verify the number to string conversion. The number should be converted to the word. For example, if user enters 8908 and function returns the output as Eight Thousand Nine Hundred and Eight only. I thought that it is very simple. After starting to write it, I faced few issues. Thats why I created four functions. I have given the code below. The current code converts up to crores. This code snippet can be used in Visual Test or Visual Basic. Few changes needs to be done to use in VB Script.

Code: Returns the word to the given number

 
'---------------------------
' Method : NumberToWord
' Author : T.Palani Selvam
' Purpose :   Returns the word to the given number.
' Parameters: sGivenNum - String, contains to be converted number.
'
' Returns :   Returns String of corresponding number.
' Caller : 
' Calls  : - Nil -
'----------------------------
Function NumberToWord(sGivenNum As String) As String
Dim lBeforeDecimal As Long, lAfterDecimal As Long
Dim iDecimalPos As Integer, iIndex As Integer
Dim sBeforeDecimalWord As String, sAfterDecimalWord As String
Dim sResult As String, sChar As String

 'sResult = Null
    sGivenNum = Trim(Str(Val(sGivenNum)))
    If Val(sGivenNum) = 0 Then
       NumberToWord = "Zero"
       Exit Function
    End If
    sAfterDecimalWord = ""
 sBeforeDecimalWord = ""
    iDecimalPos = InStr(sGivenNum, ".")
    If iDecimalPos = 0 Then
       lBeforeDecimal = Val(sGivenNum)
    Else
       'sGivenNum = Format(sGivenNum, "#####.00")
       lBeforeDecimal = Val(Left(sGivenNum, iDecimalPos - 1))
       lAfterDecimal = Val(Mid(sGivenNum, iDecimalPos + 1))
       If (lAfterDecimal <> 0) Then 
   'sAfterDecimalWord = " Paise " + PrimaryConversion(lAfterDecimal)
   sAfterDecimalWord = " Point" '+ PrimaryConversion(lAfterDecimal)
   For iIndex = 1 To Len(trim(str(lAfterDecimal)))
    sChar = Mid$(trim(str(lAfterDecimal)), iIndex, 1)
    sAfterDecimalWord = sAfterDecimalWord + " " + PrimaryConversion(val(sChar))
   Next iIndex
  End IF
       If (lBeforeDecimal = 0) Then
   NumberToWord = sAfterDecimalWord
   Exit Function
  End IF
    End If

    sBeforeDecimalWord = SplitType(10000000, " Crore ", lBeforeDecimal)
    sBeforeDecimalWord = sBeforeDecimalWord + SplitType(100000, " Lakh ", lBeforeDecimal)
    sBeforeDecimalWord = sBeforeDecimalWord + SplitType(1000, " Thousand ", lBeforeDecimal)
    sBeforeDecimalWord = sBeforeDecimalWord + SplitType(100, " Hundred ", lBeforeDecimal)
    If sBeforeDecimalWord = "" Then
       sBeforeDecimalWord = PrimaryConversion(lBeforeDecimal)
    Else
       sBeforeDecimalWord = sBeforeDecimalWord + "and " + PrimaryConversion(lBeforeDecimal)
    End If
 sResult = sBeforeDecimalWord

    If sAfterDecimalWord = "" Then
       sResult = sBeforeDecimalWord
    Else
       'sResult = sBeforeDecimalWord + " and" + sAfterDecimalWord
    sResult = sBeforeDecimalWord + sAfterDecimalWord
    End If

    NumberToWord = sResult '+ " Only"
End Function

Code: Set the word according to level

 
'-------------------------
' Method : SplitType
' Author : T.Palani Selvam
' Purpose :   Splits a level to next level.
' Parameters: lNumType - Long, contains like 100, 1000
'   sWord - String, contains before conversioned word.
' Returns :   Returns String of corresponding number.
'----------------------------
Function SplitType(lNumType As Long, sWord As String,lBeforeDecimal As long ) As String
'Dim lBeforeDecimal As Long
Dim lNumberType As Long

    SplitType = ""
    lNumberType = lBeforeDecimal \ lNumType
    If lNumberType > 0 Then
       lBeforeDecimal = lBeforeDecimal - lNumberType * lNumType
       SplitType = PrimaryConversion(lNumberType) + sWord
    End If
End Function

Code: Parse a string to the given condition

 
'--------------------------
' Method : GetParsedString
' Author : T.Palani Selvam
' Purpose :   Parse a string to the given condition
' Parameters: sData  - String, contains full string..
'    sSeparate - String, contains separation string
'    iOccur - String, contains position of the Split
' Returns :   Returns String, Null or other values.
'--------------------------
Function GetParsedString(sData As String, sSeparate As String, iOccur As Integer) As String
Dim iPosition As Integer, iIndex As Integer
Dim sTemp As String

 GetParsedString = Null
 sTemp = sData
  
 For iIndex =1 To (iOccur -1) Step 1
  iPosition = Instr(sTemp,sSeparate)
  If (iPosition > 0) Then
    sTemp=Mid$(sTemp,len(sSeparate) + iPosition)   
  Else
   Print(sSeparate + " is not occured")    
   Exit Function
  End If
'  Print "Original Symbol: " + sTemp, sSeparate
 Next iIndex
 iPosition = Instr(sTemp,sSeparate)
 If (iPosition > 0) Then
   sTemp=Left$(sTemp,iPosition - 1)   
 End If
 GetParsedString = sTemp
End Function

Code: Converts primary number to word

 
'----------------------
' Method : PrimaryConversion
' Author : T.Palani Selvam
' Purpose :   It converts primary number to string.
' Parameters: lNumber - Long, contains number
'
' Returns :   Returns String of corresponding number.
'-------------------------
Function PrimaryConversion(lNumber As Long) As String
   PrimaryConversion = ""
   Select Case lNumber
     Case 0
     Case 1 
  PrimaryConversion = "One"
     Case 2 
  PrimaryConversion = "Two"
     Case 3 
  PrimaryConversion = "Three"
     Case 4 
  PrimaryConversion = "Four"
     Case 5 
  PrimaryConversion = "Five"
     Case 6 
  PrimaryConversion = "Six"
     Case 7 
  PrimaryConversion = "Seven"
     Case 8 
  PrimaryConversion = "Eight"
     Case 9 
  PrimaryConversion = "Nine"
     Case 10 
  PrimaryConversion = "Ten"
     Case 11 
  PrimaryConversion = "Eleven"
     Case 12 
  PrimaryConversion = "Twelve"
     Case 13 
  PrimaryConversion = "Thirteen"
     Case 14 
  PrimaryConversion = "Fourteen"
     Case 15 
  PrimaryConversion = "Fifteen"
     Case 16 
  PrimaryConversion = "Sixteen"
     Case 17 
  PrimaryConversion = "Seventeen"
     Case 18 
  PrimaryConversion = "Eighteen"
     Case 19 
  PrimaryConversion = "Nineteen"
     Case 20
  PrimaryConversion = "Twenty"
     Case 30 
  PrimaryConversion = "Thirty"
     Case 40 
  PrimaryConversion = "Forty"
     Case 50 
  PrimaryConversion = "Fifty"
     Case 60 
  PrimaryConversion = "Sixty"
     Case 70 
  PrimaryConversion = "Seventy"
     Case 80 
  PrimaryConversion = "Eighty"
     Case 90 
  PrimaryConversion = "Ninety"
     Case Else  
  PrimaryConversion = PrimaryConversion(lNumber - (lNumber Mod 10)) + " " + PrimaryConversion(lNumber Mod 10)
   End Select
End Function

Checking Mail Notification

Earlier I have written the code to verify the mails from Microsoft Outlook Express. I used to call CDO(Collaboration Data Objects) object methods. I developed a small VB application to delete all the objects from Inbox. I think, now few methods are deprecated.

Code:

 
'It is possible, by calling OLE objects from CDO.dll
'Mostly it will be in C:\Program Files\Common Files\System\Mapi\1033\NT\
'-------------------------
' Method : CheckMail
' Author : T.Palani Selvam
' Purpose :   Check the mails in the MS Outlook Mail Client for the particular subject & its status.
' Parameters: sDatavalue, String - Contains  Username, Password of the MS outlook, Subject & Status of mail.
' Returns :   Returns Integer data type(True or False.)
'----------------------------
Function CheckMail(sDataValue As String) As Integer
Dim objSession As Variant
Dim objInbox As Variant
Dim objMessages As Variant
Dim objItem As Variant
Dim intIndex As Integer
Dim intCount As Integer
Dim varReceived As Variant
Dim iStatus As Integer  'To get Current status of the message.
Dim sSubject As String  'Subject of the current message.
Dim sUser As String, sPword As String, sSearch As String, sStatus As String  'Information gets from the Data value
Dim iPosition As Integer, iPosition1 As Integer
Dim sTemp As String
Dim iResult As Integer

 iResult = False  'Initializing function
    'Error Information Handling
On Local Error GoTo Error_Handler1

 '****** Parsing information from Datavalue
 sTemp = sDatavalue 
 intCount = 1
 While (Instr(sTemp,"::") <>0 )
  iPosition = Instr(sTemp,"::") 

  Select Case intCount
  Case 1
   sUser = Left$ (sTemp, iPosition - 1)
  Case 2
   sPWord = Left$(sTemp, iPosition - 1)
  Case 3
   sSearch = Left$(sTemp, iPosition - 1)
  'Case 4
   'sStatus = Left$(sTemp, iPosition)
   sStatus = Mid$ (sTemp, iPosition + 2)
  Case Else
   LogWrite("CheckMail: More information is given in data file.", 1)
  End Select
  intCount = intCount + 1
  sTemp = Mid$ (sTemp, iPosition + 2)
 Wend
 '**** End Parsing Information

 Logwrite("Search Mail Status: " + sStatus + " & Subject String: " + sSearch, 1)
 'Set objSession = CreateObject("MAPI.Session")  
 objSession = OleCreateObject("MAPI.Session")  ' Create MAPI session

 'objSession.Logon strUser, strPword, False, False, 0
 OleDispatch(objSession,"Logon",sUser, sPword,False, False, 0) ' Logon using an existing MAPI session

 'Set objInbox = objSession.Inbox
 objInbox=OleDispatch(objSession,"Inbox")  ' Get inbox folder

 'Set objMessages = objInbox.Messages
 objMessages=OleDispatch(objInbox,"Messages")  'Get all messages

 
 intCount=OleGetProperty(objMessages,"Count")

 LogWrite("Total Messages in Outlook: " + str(intCount) , 1)

 sStatus = Trim (sStatus)

 For intIndex=1 To intCount  Step 1
  objItem=OleDispatch(objMessages,"Item",intIndex)   'Get Each message

  sSubject = OleGetProperty(objItem,"Subject")
  iStatus =   OleGetProperty(objItem,"Unread")


  If (InStr(UCase(sSubject), UCase(sSearch)) <> 0) Then
      If (iStatus AND (Instr(lCase(sStatus),"read") > 1)) Then
    iResult = True
    Exit For
   ElseIf ((Not iStatus) AND (Instr(lCase(sStatus),"read") = 1)) Then
    iResult = True
    Exit For
   End If

  End If
 Next intIndex

 ' Logoff from MAPI Session
 OleDispatch(objSession,"Logoff")
 'Set objSession = Nothing
 OleReleaseObject(objSession)
 
 If (iResult) Then
  LogWrite("Successfully Mail is checked in the Outlook.",2)
 Else
  LogWrite("Failure to check Mail in the Outlook.",1)
  'giTestResult = giTestResult  + 10
 End IF
 CheckMail = iResult

 Exit Sub

Error_Handler1:

 If InStr(UCase(Error$), "LOGON") <> 0 And InStr(UCase(Error$), "FAIL") <> 0 Then
  LogWrite("CheckMail : Username and password of Outlook information are incorrect. ", 1) 
  LogWrite("CheckMail : MS Outlook Login status is Failure.", 1) 
 End If


 If Not (objSession = NULL) Then
  OleReleaseObject(objSession)
 End If

 'PRINT "[Failed At] " ERF "(" ERL ") :  " ERROR$   'Actual location.
 'PRINT "[Trapped At] " ERF(1) "(" ERL(1) ")"   'Trapped location.
 LogWrite("[Failed At] " + ERF(0)+ "("+ str(ERL) +") :  "+ ERROR$,1)   'Actual location.
 Logwrite("[Trapped At] "+ ERF(1)+ "("+ str(ERL(1))+ ")",1)   'Trapped location.
 LogWrite("Error Handling: Failure to check Mail in the Outlook.",1)

 glCellRow = glCellRow + 1
 setResultDetails("Error: " + Error$ ,glCellRow,3)  'Write into Excel

End Function

MS XML Parser by Visual Basic

I love to use XML Parser. It is very easy to do by Visual basic. You can get the equivalent visual test code here - Visual Test - MS XML Parser. I'm thinking to use it in Quick Test Professional (QTP). Below code snippets are simple and easy to use.

Case1: To load any XML content

 
'-----------------------------------------
' Method    :   XMLParserLoadXML
' Author    :   T.Palani Selvam
' Purpose   :   Creates XML Parsing object according to the given XML String.
' Parameters:   sXML - String, contains data in XML Format.
' Returns   :   Returns a Object, which contains XML Parsing object.
' Caller    :   - Nil
' Calls     :   - Nil -
'------------------------------------------
Function XMLParserLoadXML(sXML As String) As Variant
Dim objXML As Variant

    XMLParserLoadXML = Null

    Set objXML = CreateObject("Microsoft.XMLDOM")     'Declare a Object
    objXML.async = False
    objXML.loadXML (sXML)  'Load xmlformat String

    'OleSetProperty(objXML,"preserveWhiteSpace") = False

    If (objXML.parseError <> 0) Then
        LogWrite ("Parsing Error in the File :" + sXMLFile)
        Exit Function
    End If
    
                    'Top Node of given file
    Set XMLParserLoadXML = objXML.documentElement
End Function

Case2: It parsed the given tag in given content and returns the node.

 
'-----------------------------------------
' Method    :   XMLParser
' Author    :   T.Palani Selvam
' Purpose   :   Creates XML Parsing object according to the given XML Format File and Element.
' Parameters:   sXMLFile - String, contains a file name, which is in XML Format.
'               sTag - String, contains element name from which Tag or element based object to be returned.
' Returns   :   Returns a Object, which contains XML Parsing object.
' Caller    :   - Nil
' Calls     :   - Nil -
'-----------------------------------------
Function XMLParser(sXMLFile As String, sTag As String) As Variant
Dim objXML As Variant, objNode As Variant, objTemp As Variant, objRoot As Variant
'Dim varTest As Variant
Dim iIndex As Integer, iTemp As Integer
'Dim objRoot As node

    XMLParser = Null
    sTag = Trim(sTag)
    Set objXML = CreateObject("Microsoft.XMLDOM")     'Declare a Object
    objXML.async = False
    objXML.Load (sXMLFile)  'Load xmlformat file

    If (objXML.parseError <> 0) Then
        LogWrite ("Parsing Error in the File :" + sXMLFile)
        MsgBox ("Parsing Error in the File :" + sXMLFile)
        Exit Function
    End If
    
                    'Top Node of given file
    Set objRoot = objXML.documentElement
    'Print "XML File is : " & sXMLFile
    'Print objRoot.nodeName & " Name of the node.."

    If ((sTag = "") Or (sTag = objRoot.nodeName)) Then
        'XMLParser = CVar(objRoot)
        Set XMLParser = objRoot
        'Set varTest = objRoot
        'XMLParser = objRoot
        Exit Function
    End If

    If objRoot.hasChildNodes <> 0 Then
        objTemp = objRoot.childNodes
        iTemp = objTemp.length

        For iIndex = 0 To iTemp - 1
            objNode = objTemp.Item(iIndex)
            If (UCase(Trim(objNode.nodeName)) = UCase(sTag)) Then
                XMLParser = objNode
                Exit Function
            Else
                Set objNode = Nothing
            End If
        Next iIndex
    End If

    objTemp = objXML.getElementsByTagName(sTag) 'Search whole file with sTag
    iTemp = objTemp.length
    If (iTemp > 0) Then
        objNode = objTemp.Item(0)
        XMLParser = objNode
    End If

End Function