QTP_Excel write

'Core points of this execise:

'1. Excel writing function

'2. Excel add link to cell

'3. Creat new sheet 

'4. Compare sheet content; add compare result to new sheet; add color to the result

'5. New  a 'Function', 'sub'

Set ExcelObj = CreateObject("Excel.Application") 

' add a new Workbooks and a new Sheet 
ExcelObj.Workbooks.Add 

Dim i,str  
Dim filename  

'2 sheets  
For i=1 to 2  
        Set NewSheet = ExcelObj.Sheets.Item(i)

        'define sheet name  
        NewSheet.Name = "Page Test "  & i  

        ' customize the Sheet layout 
         NewSheet.Cells(1,1).Value = "Website"  
        NewSheet.Cells(2,1).Value = "163.com" 

        'set different to the same cell in different sheet  
        If i=1 Then  
                NewSheet.Cells(3,1).Value = "hotmail.com" 
        Else  
                NewSheet.Cells(3,1).Value = "hotmail" 
        End If  
        
        'add link to cells  
        NewSheet.Hyperlinks.Add NewSheet.Cells(2,1), " http://www.163.com/ " 
        NewSheet.Hyperlinks.Add NewSheet.Cells(3,1), " http://www.hotmail.com/ "  

Next  

 ' call procesure to save file 
 filename="C:\test.xls" 
Call Savefile (filename)  

Dim rownum, colnum  
        rownum=3     'define row number  
        colnum=3      'define column number  

'call function to compare 2 sheets  
Set NewSheet = ExcelObj.Sheets.Item(3) 
NewSheet.Name = "Compare Result" 

'call function to find the compare result  
str=CompareSheet(ExcelObj.Sheets.Item(1),ExcelObj.Sheets.Item(2), rownum, colnum )  

If str=null then  
        NewSheet.Cells(1,1).Value ="They are the same."  
else  
    NewSheet.Cells(1,1).Value ="They are different."  
        NewSheet.Cells(2,1).Value =str  
End If  

'save file  
ExcelObj.ActiveWorkbook.Save  
        
' close the application and clean the object   
 ExcelObj.Quit 
Set ExcelObj = Nothing  

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
'sub: save as file  
Sub Savefile (filename)  
    Set fso = CreateObject("Scripting.FileSystemObject")  

        If fso.FileExists(filename) Then  
                fso.DeleteFile(filename)  'if file exists, delete it  
   end if  

        ExcelObj.ActiveWorkbook.SaveAs filename  

End Sub  

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
'function: compare 2 sheets content  
Function CompareSheet(sheet1, sheet2, row, col)  
        If sheet1 is nothing or sheet2 is nothing  Then  
                CompareSheet=false  
        End If  

        Dim i, j  
        
        For i=1 to row  
                For j=1 to col  
                        If sheet1.cells(i,j)<>sheet2.cells(i,j) Then  
                                sheet1.cells(i,j).Font.Color=vbRed     'if 2 cells are different,, color of font will turn to red
                                str= "Cell(" & i & "," & j & "): '" & sheet1.cells(i,j) & "' and '" & sheet2.cells(i,j) & "'; "  'record the different content  
                        Else  
                                sheet1.cells(i,j).Font.Color=vbBlue    'if 2 cells are the same, color of font will turn to Blue  
                        End If  
                Next  
        Next  

CompareSheet=trim(str)  
End Function