QTP Excel函数

 


QTP Excel函数 


 


Dim ExcelApp 'As Excel.Application 


 Dim excelSheet 'As Excel.worksheet 


 Dim excelBook 'As Excel.workbook 


 Dim fso 'As scrīpting.FileSystemObject 


 ' ********************************************************************************************* 


 ' 函数说明：创建一个Excel应用程序ExcelApp,并创建一个新的工作薄Workbook; 


 ' 参数说明：无 


 ' 调用方法: 


 ' CreateExcel() 


 ' ********************************************************************************************* 


Function CreateExcel() 


 Dim excelSheet 


 ExcelApp = CreateObject("Excel.Application") 


 ExcelApp.Workbooks.Add() 


 ExcelApp.Visible = True 


 CreateExcel = ExcelApp 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：关闭Excel应用程序; 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' 调用方法: 


 ' CloseExcel(ExcelApp) 


 ' ********************************************************************************************* 


 Sub CloseExcel(ByVal ExcelApp) 


 excelSheet = ExcelApp.ActiveSheet 


 excelBook = ExcelApp.ActiveWorkbook 


 fso = CreateObject("scrīpting.FileSystemObject") 


 On Error Resume Next 


 fso.CreateFolder("C:\Temp") 


 fso.DeleteFile("C:\Temp\ExcelExamples.xls") 


 excelBook.SaveAs("C:\Temp\ExcelExamples.xls") 


 ExcelApp.Quit() 


 ExcelApp = Nothing 


 fso = Nothing 


 Err = 0 


 On Error GoTo 0 


 End Sub 


 


 ' ********************************************************************************************* 


 ' 函数说明：保存工作薄; 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 



 ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; 


 ' (3)path:保存的路径; 


 ' 返回结果： 


 ' (1)保存成功，返回字符串：OK 


 ' (2)保存失败，返回字符串：Bad Worksheet Identifier 


 ' 调用方法: 


 ' ret = SaveWorkbook(ExcelApp, "Book1", "D:\Example1.xls") 


 ' ********************************************************************************************* 


 Function SaveWorkbook(ByVal ExcelApp, ByVal workbookIdentifier, ByVal path) 'As String 


 Dim workbook 


 On Error Resume Next '启用错误处理程序 


 workbook = ExcelApp.Workbooks(workbookIdentifier) 


 On Error GoTo 0 '禁用错误处理程序 


 If Not workbook Is Nothing Then 


 If path = "" Or path = workbook.FullName Or path = workbook.Name Then 


 workbook.Save() 


 Else 


 fso = CreateObject("scrīpting.FileSystemObject") 


 


 '判断路径中是否已添加扩展名.xls 


 If InStr(path, ".") = 0 Then 


 path = path & ".xls" 


 End If 


 


 '删除路径下现有同名的文件 


 On Error Resume Next 


 fso.DeleteFile(path) 


 fso = Nothing 


 Err = 0 


 On Error GoTo 0 


 


 workbook.SaveAs(path) 


 End If 


 SaveWorkbook = "OK" 


 Else 


 SaveWorkbook = "Bad Workbook Identifier" 


 End If 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：设置工作表excelSheet单元格的值 


 ' 参数说明： 


 ' (1)excelSheet:工作表名称; 


 ' (2)row:列的序号,第一列为1; 


 ' (3)column:行的序号,第一行为1; 


 ' (4)value:单元格要设置的值; 


 ' 返回结果： 



 ' 无返回值 


 ' 调用方法: 


 ' SetCellValue excelSheet1, 1, 2, "test" 


 ' ********************************************************************************************* 


 Sub SetCellValue(ByVal excelSheet, ByVal row, ByVal column, ByVal value) 


 On Error Resume Next 


 excelSheet.Cells(row, column) = value 


 On Error GoTo 0 


 End Sub 


 


 'The GetCellValue returns the cell's value according to its row column and sheet 


 'excelSheet - the Excel Sheet in which the cell exists 


 'row - the cell's row 


 'column - the cell's column 


 'return 0 if the cell could not be found 


 ' ********************************************************************************************* 


 ' 函数说明：获取工作表excelSheet单元格的值 


 ' 参数说明： 


 ' (1)excelSheet:工作表名称; 


 ' (2)row:列的序号; 


 ' (3)column:行的序号; 


 ' 返回结果： 


 ' (1)单元格存在,返回单元格值; 


 ' (2)单元格不存在，返回0; 


 ' 调用方法: 


 ' set CellValue = GetCellValue(excelSheet, 1, 2) 


 ' ********************************************************************************************* 


 Function GetCellValue(ByVal excelSheet, ByVal row, ByVal column) 


 value = 0 


 Err = 0 


 On Error Resume Next 


 tempValue = excelSheet.Cells(row, column) 


 If Err = 0 Then 


 value = tempValue 


 Err = 0 


 End If 


 On Error GoTo 0 


 GetCellValue = value 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：获取并返回工作表对象 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)sheetIdentifier:属于ExcelApp的工作表名称; 


 ' 返回结果： 


 ' (1)成功：工作表对象Excel.worksheet 


 ' (1)失败：Nothing 


 ' 调用方法: 


 ' Set excelSheet1 = GetSheet(ExcelApp, "Sheet Name") 


 ' ********************************************************************************************* 



 Function GetSheet(ByVal ExcelApp, ByVal sheetIdentifier) 


 On Error Resume Next 


 GetSheet = ExcelApp.Worksheets.Item(sheetIdentifier) 


 On Error GoTo 0 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：添加一张新的工作表 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; 


 ' (2)sheetName:要插入的工作表名称; 


 ' 返回结果： 


 ' (1)成功：工作表对象worksheet 


 ' (1)失败：Nothing 


 ' 调用方法: 


 ' InsertNewWorksheet(ExcelApp, workbookIdentifier, "new sheet") 


 ' ********************************************************************************************* 


 Function InsertNewWorksheet(ByVal ExcelApp, ByVal workbookIdentifier, ByVal sheetName) 


 Dim workbook 'As Excel.workbook 


 Dim worksheet 'As Excel.worksheet 


 


 '如果指定的工作薄不存在，将在当前激活状态的工作表中添加工作表 


 If workbookIdentifier = "" Then 


 workbook = ExcelApp.ActiveWorkbook 


 Else 


 On Error Resume Next 


 Err = 0 


 workbook = ExcelApp.Workbooks(workbookIdentifier) 


 If Err <> 0 Then 


 InsertNewWorksheet = Nothing 


 Err = 0 


 Exit Function 


 End If 


 On Error GoTo 0 


 End If 


 


 sheetCount = workbook.Sheets.Count '获取工作薄中工作表的数量 


 workbook.Sheets.Add, sheetCount '添加工作表 


 worksheet = workbook.Sheets(sheetCount + 1) '初始化worksheet为新添加的工作表对象 


 


 '设置新添加的工作表名称 


 If sheetName <> "" Then 


 worksheet.Name = sheetName 


 End If 


 



 InsertNewWorksheet = worksheet 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：修改工作表的名称; 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; 


 ' (3)worksheetIdentifier:属于workbookIdentifier工作薄的工作表名称; 


 ' (4)sheetName:修改后的工作表名称; 


 ' 返回结果： 


 ' (1)修改成功，返回字符串：OK 


 ' (2)修改失败，返回字符串：Bad Worksheet Identifier 


 ' 调用方法: 


 ' set ret = RenameWorksheet(ExcelApp, "Book1", "Sheet1", "Sheet Name") 


 ' ********************************************************************************************* 


 Function RenameWorksheet(ByVal ExcelApp, ByVal workbookIdentifier, ByVal worksheetIdentifier, ByVal 
sheetName) 


 Dim workbook 


 Dim worksheet 


 On Error Resume Next 


 Err = 0 


 workbook = ExcelApp.Workbooks(workbookIdentifier) 


 If Err <> 0 Then 


 RenameWorksheet = "Bad Workbook Identifier" 


 Err = 0 


 Exit Function 


 End If 


 worksheet = workbook.Sheets(worksheetIdentifier) 


 If Err <> 0 Then 


 RenameWorksheet = "Bad Worksheet Identifier" 


 Err = 0 


 Exit Function 


 End If 


 worksheet.Name = sheetName 


 RenameWorksheet = "OK" 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：删除工作表; 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)workbookIdentifier:属于ExcelApp的工作薄名称; 


 ' (3)worksheetIdentifier:属于workbookIdentifier工作薄的工作表名称; 


 ' 返回结果： 


 ' (1)删除成功，返回字符串：OK 


 ' (2)删除失败，返回字符串：Bad Worksheet Identifier 


 ' 调用方法: 


 ' set ret = RemoveWorksheet(ExcelApp, "Book1", "Sheet1") 


 ' ********************************************************************************************* 


 Function RemoveWorksheet(ByVal ExcelApp, ByVal workbookIdentifier, ByVal worksheetIdentifier) 



 Dim workbook 'As Excel.workbook 


 Dim worksheet 'As Excel.worksheet 


 On Error Resume Next 


 Err = 0 


 workbook = ExcelApp.Workbooks(workbookIdentifier) 


 If Err <> 0 Then 


 RemoveWorksheet = "Bad Workbook Identifier" 


 Exit Function 


 End If 


 worksheet = workbook.Sheets(worksheetIdentifier) 


 If Err <> 0 Then 


 RemoveWorksheet = "Bad Worksheet Identifier" 


 Exit Function 


 End If 


 worksheet.Delete() 


 RemoveWorksheet = "OK" 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：添加新的工作薄 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' 返回结果： 


 ' (1)成功：工作表对象NewWorkbook 


 ' (1)失败：Nothing 


 ' 调用方法: 


 ' set NewWorkbook = CreateNewWorkbook(ExcelApp) 


 ' ********************************************************************************************* 


 Function CreateNewWorkbook(ByVal ExcelApp) 


 NewWorkbook = ExcelApp.Workbooks.Add() 


 CreateNewWorkbook = NewWorkbook 


 End Function 


 


 ' ********************************************************************************************* 


 ' 函数说明：打开工作薄 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)path:要打开的工作薄路径; 


 ' 返回结果： 


 ' (1)成功：工作表对象NewWorkbook 


 ' (1)失败：Nothing 


 ' 调用方法: 


 ' set NewWorkbook = CreateNewWorkbook(ExcelApp) 


 ' ********************************************************************************************* 


 Function OpenWorkbook(ByVal ExcelApp, ByVal path) 


 On Error Resume Next 


 NewWorkbook = ExcelApp.Workbooks.Open(path) 


 ōpenWorkbook = NewWorkbook 


 On Error GoTo 0 


 End Function 


 



 ' ********************************************************************************************* 


 ' 函数说明：将工作薄设置为当前工作状态 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)workbookIdentifier:要设置为当前工作状态的工作薄名称; 


 ' 返回结果：无返回值; 


 ' 调用方法: 


 ' ActivateWorkbook(ExcelApp, workbook1) 


 ' ********************************************************************************************* 


 Sub ActivateWorkbook(ByVal ExcelApp, ByVal workbookIdentifier) 


 On Error Resume Next 


 ExcelApp.Workbooks(workbookIdentifier).Activate() 


 On Error GoTo 0 


 End Sub 


 


 ' ********************************************************************************************* 


 ' 函数说明：关闭Excel工作薄; 


 ' 参数说明： 


 ' (1)ExcelApp:Excel应用程序名称; 


 ' (2)workbookIdentifier: 


 ' 调用方法: 


 ' CloseWorkbook(ExcelApp, workbookIdentifier) 


 ' ********************************************************************************************* 


 Sub CloseWorkbook(ByVal ExcelApp, ByVal workbookIdentifier) 


 On Error Resume Next 


 ExcelApp.Workbooks(workbookIdentifier).Close() 


 On Error GoTo 0 


 End Sub 


 


 ' ********************************************************************************************* 


 ' 函数说明：判断两个工作表对应单元格内容是否相等 


 ' 参数说明： 


 ' (1)sheet1:工作表1的名称; 


 ' (2)sheet2:工作表2的名称; 


 ' (3)startColumn:开始比较的行序号; 


 ' (4)numberOfColumns:要比较的行数; 


 ' (5)startRow:开始比较的列序号; 


 ' (6)numberOfRows:要比较的列数; 


 ' (7)trimed:是否先除去字符串开始的空格和尾部空格后再进行比较,true或flase; 


 ' 返回结果： 


 ' (1)两工作表对应单元格内容相等：true 


 ' (2)两工作表对应单元格内容不相等:flase 


 ' 调用方法: 


 ' ret = CompareSheets(excelSheet1, excelSheet2, 1, 10, 1, 10, False) 


 ' ********************************************************************************************* 


 Function CompareSheets(ByVal sheet1, ByVal sheet2, ByVal startColumn, ByVal numberOfColumns, ByVal 
startRow, ByVal numberOfRows, ByVal trimed) 


 Dim returnVal 'As Boolean 


 returnVal = True 


 


 '判断两个工作表是否都存在,任何一个不存在停止判断，返回flase 



 If sheet1 Is Nothing Or sheet2 Is Nothing Then 


 CompareSheets = False 


 Exit Function 


 End If 


 


 '循环判断两个工作表单元格的值是否相等 


 For r = startRow To (startRow + (numberOfRows - 1)) 


 For c = startColumn To (startColumn + (numberOfColumns - 1)) 


 Value1 = sheet1.Cells(r, c) 


 Value2 = sheet2.Cells(r, c) 


 


 '如果trimed为true,去除单元格内容前面和尾部空格 


 If trimed Then 


 Value1 = Trim(Value1) 


 Value2 = Trim(Value2) 


 End If 


 


 '如果单元格内容不一致,函数返回flase 


 If Value1 <> Value2 Then 


 Dim cell 'As Excel.Range 


 '修改sheet2工作表中对应单元格值 


 sheet2.Cells(r, c) = "Compare conflict - Value was '" & Value2 & "', Expected value is '" & Value1 
& "'." 


 '初始化cell为sheet2中r:c单元格对象 


 cell = sheet2.Cells(r, c) ' 


 '将sheet2工作表中对应单元格的颜色设置为红色 


 cell.Font.Color = vbRed 


 returnVal = False 


 End If 


 Next 


 Next 


 CompareSheets = returnVal 


 End Function