QTP基础代码收集《二》

3、 使用qtp发mail
' Example 1
  Function SendMail(SendTo,Subject, Body, Attachment)
  Setōl=CreateObject("Outlook.Application")
  Set Mail=ol.CreateItem(0)
  Mail.to=SendTo
  Mail.Subject=Subject
  Mail.Body=Body
  If (Attachment<> "") Then
  Mail.Attachments.Add(Attachment)
  End If
  Mail.Send
  ol.Quit
  Set Mail = Nothing
  Set &#333;l = Nothing
  End Function
  
  ' Example 2
  Function SendMail(SendFrom,SendTo, Subject, Body)
  Set&#333;bjMail=CreateObject("CDONTS.Newmail")
  ObjMail.From = SendFrom
  ObjMail.To = SendTo
  ObjMail.Subject = Subject
  ObjMail.Body = Body
  ObjMail.Send
  Set &#333;bjMail = Nothing
  End Function
4、Excel操作函数集合：
Dim ExcellApp 'As Excel.Application
  Dim excelSheet1 'AsExcel.worksheet
  Dim excelSheet2 'AsExcel.worksheet
  
  Set ExcelApp =CreateExcel()
  
  'Create a workbook with twoworksheets
  ret = RenameWorksheet(ExcelApp,"Book1", "Sheet1", "Example1 Sheet Name")
  ret = RenameWorksheet(ExcelApp,"Book1", "Sheet2", "Example2 Sheet Name")
  ret = RemoveWorksheet(ExcelApp,"Book1", "Sheet3")
  
  'SaveAs the work book
  ret = SaveWorkbook(ExcelApp,"Book1", "D:\Example1.xls")
  
  'Fill worksheets
  Set excelSheet1 =GetSheet(ExcelApp, "Example1 Sheet Name")
  Set excelSheet2 =GetSheet(ExcelApp, "Example2 Sheet Name")
  For column = 1 to 10
  For row = 1 to 10
  SetCellValue excelSheet1, row,column, row + column
  SetCellValue excelSheet2, row,column, row + column
  Next
  Next
  
  'Compare the twoworksheets
  ret =CompareSheets(excelSheet1, excelSheet2, 1, 10, 1, 10, False)
  If ret Then
  MsgBox "The two worksheets areidentical"
  End If
  
  'Change the values in onesheet
  SetCellValue excelSheet1, 1, 1,"Yellow"
  SetCellValue excelSheet2, 2, 2,"Hello"
  
  'Compare the worksheetsagain
  ret =CompareSheets(excelSheet1, excelSheet2, 1, 10, 1, 10, True)
  If Not ret Then
  MsgBox "The two worksheets arenot identical"
  End If
  
  'save the workbook by indexidentifier
  SaveWorkbook ExcelApp, 1,""
  
  'Close the Excelapplication
  CloseExcel ExcelApp
  
  '****************************************** Function Library***********************************************************
Dim ExcelApp 'As Excel.Application
  Dim excelSheet 'AsExcel.worksheet
  Dim excelBook 'AsExcel.workbook
  Dim fso 'Asscr&#299;pting.FileSystemObject
  
  ' This function will return anew Excel Object with a default new Workbook
  Function CreateExcel() 'AsExcel.Application
  Dim excelSheet 'AsExcel.worksheet
  Set ExcelApp =CreateObject("Excel.Application") 'Create a new excel Object
  ExcelApp.Workbooks.Add
  ExcelApp.Visible = True
  Set CreateExcel =ExcelApp
  End Function
  
  'This function will close thegiven Excel Object
  'excelApp - an Excelapplication object to be closed
  Sub CloseExcel(ExcelApp)
  Set excelSheet =ExcelApp.ActiveSheet
  Set excelBook =ExcelApp.ActiveWorkbook
  Set fso =CreateObject("scr&#299;pting.FileSystemObject")
  On Error Resume Next
  fso.CreateFolder"C:\Temp"
  fso.DeleteFile"C:\Temp\ExcelExamples.xls"
  excelBook.SaveAs"C:\Temp\ExcelExamples.xls"
  ExcelApp.Quit
  Set ExcelApp = Nothing
  Set fso = Nothing
  Err = 0
  On Error GoTo 0
  End Sub
  
  'The SaveWorkbook method willsave a workbook according to the workbookIdentifier
  'The method will overwrite thepreviously saved file under the given path
  'excelApp - a reference to theExcel Application
  'workbookIdentifier - The nameor number of the requested workbook
  'path - the location to whichthe workbook should be saved
  'Return "OK" on success and"Bad Workbook Identifier" on failure
  Function SaveWorkbook(ExcelApp,workbookIdentifier, path) 'As String
  Dim workbook 'AsExcel.workbook
  On Error Resume Next
  Set workbook =ExcelApp.Workbooks(workbookIdentifier)
  On Error GoTo 0
  If Not workbook Is NothingThen
  If path = "" Or path =workbook.FullName Or path = workbook.Name Then
  workbook.Save
  Else
  Set fso =CreateObject("scr&#299;pting.FileSystemObject")
  
  'if the path has no fileextension then add the 'xls' extension
  If InStr(path, ".") = 0Then
  path = path &".xls"
  End If
  
  On Error Resume Next
  fso.DeleteFile path
  Set fso = Nothing
  Err = 0
  On Error GoTo 0
  workbook.SaveAs path
  End If
  SaveWorkbook = "OK"
  Else
  SaveWorkbook = "Bad WorkbookIdentifier"
  End If
  End Function
  
  'The SetCellValue method setsthe given 'value' in the cell which is identified by
  'its row column and parentExcel sheet
  'excelSheet - the excel sheetthat is the parent of the requested cell
  'row - the cell's row in theexcelSheet
  'column - the cell's column inthe excelSheet
  'value - the value to be set inthe cell
  Sub SetCellValue(excelSheet,row, column, value)
  On Error Resume Next
  excelSheet.Cells(row, column) =value
  On Error GoTo 0
  End Sub
  
  'The GetCellValue returns thecell's value according to its row column and sheet
  'excelSheet - the Excel Sheetin which the cell exists
  'row - the cell's row
  'column - the cell'scolumn
  'return 0 if the cell could notbe found
  FunctionGetCellValue(excelSheet, row, 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
  
  'The GetSheet method returns anExcel Sheet according to the sheetIdentifier
  'ExcelApp - the Excelapplication which is the parent of the requested sheet
  'sheetIdentifier - the name orthe number of the requested Excel sheet
  'return Nothing onfailure
  Function GetSheet(ExcelApp,sheetIdentifier) 'As Excel.worksheet
  On Error Resume Next
  Set GetSheet =ExcelApp.Worksheets.Item(sheetIdentifier)
  On Error GoTo 0
  End Function
  
  'The InsertNewWorksheet methodinserts an new worksheet into the active workbook or
  'the workbook identified by theworkbookIdentifier, the new worksheet will get a default
  'name if the sheetNameparameter is empty, otherwise the sheet will have thesheetName
  'as a name.
  'Return - the new sheet as anObject
  'ExcelApp - the excelapplication object into which the new worksheet should beadded
  'workbookIdentifier - anoptional identifier of the worksheet into which the new worksheetshould be added
  'sheetName - the optional nameof the new worksheet.
  FunctionInsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName) 'AsExcel.worksheet
  Dim workbook 'AsExcel.workbook
  Dim worksheet 'AsExcel.worksheet
  
  'In case that theworkbookIdentifier is empty we will work on the activeworkbook
  If workbookIdentifier = ""Then
  Set workbook =ExcelApp.ActiveWorkbook
  Else
  On Error Resume Next
  Err = 0
  Set workbook =ExcelApp.Workbooks(workbookIdentifier)
  If Err<> 0 Then
  Set InsertNewWorksheet =Nothing
  Err = 0
  Exit Function
  End If
  On Error GoTo 0
  End If
  
  sheetCount =workbook.Sheets.Count
  workbook.Sheets.Add ,sheetCount
  Set worksheet =workbook.Sheets(sheetCount + 1)
  
  'In case that the sheetName isnot empty set the new sheet's name to sheetName
  If sheetName<> "" Then
  worksheet.Name =sheetName
  End If
  
  Set InsertNewWorksheet =worksheet
  End Function
  
  'The RenameWorksheet methodrenames a worksheet's name
  'ExcelApp - the excelapplication which is the worksheet's parent
  'workbookIdentifier - theworksheet's parent workbook identifier
  'worksheetIdentifier - theworksheet's identifier
  'sheetName - the new name forthe worksheet
  FunctionRenameWorksheet(ExcelApp, workbookIdentifier, worksheetIdentifier,sheetName) 'As String
  Dim workbook 'AsExcel.workbook
  Dim worksheet 'AsExcel.worksheet
  On Error Resume Next
  Err = 0
  Set workbook =ExcelApp.Workbooks(workbookIdentifier)
  If Err<> 0 Then
  RenameWorksheet = "Bad WorkbookIdentifier"
  Err = 0
  Exit Function
  End If
  Set worksheet =workbook.Sheets(worksheetIdentifier)
  If Err<> 0 Then
  RenameWorksheet = "BadWorksheet Identifier"
  Err = 0
  Exit Function
  End If
  worksheet.Name =sheetName
  RenameWorksheet = "OK"
  End Function
  
  'The RemoveWorksheet methodremoves a worksheet from a workbook
  'ExcelApp - the excelapplication which is the worksheet's parent
  'workbookIdentifier - theworksheet's parent workbook identifier
  'worksheetIdentifier - theworksheet's identifier
  FunctionRemoveWorksheet(ExcelApp, workbookIdentifier, worksheetIdentifier)'As String
  Dim workbook 'AsExcel.workbook
  Dim worksheet 'AsExcel.worksheet
  On Error Resume Next
  Err = 0
  Set workbook =ExcelApp.Workbooks(workbookIdentifier)
  If Err<> 0 Then
  RemoveWorksheet = "Bad WorkbookIdentifier"
  Exit Function
  End If
  Set worksheet =workbook.Sheets(worksheetIdentifier)
  If Err<> 0 Then
  RemoveWorksheet = "BadWorksheet Identifier"
  Exit Function
  End If
  worksheet.Delete
  RemoveWorksheet = "OK"
  End Function
  
  'The CreateNewWorkbook methodcreates a new workbook in the excel application
  'ExcelApp - the Excelapplication to which an new Excel workbook will be added
  FunctionCreateNewWorkbook(ExcelApp)
  Set NewWorkbook =ExcelApp.Workbooks.Add()
  Set CreateNewWorkbook =NewWorkbook
  End Function
  
  'The OpenWorkbook method opensa previously saved Excel workbook and adds it to theApplication
  'excelApp - the ExcelApplication the workbook will be added to
  'path - the path of theworkbook that will be opened
  'return Nothing onfailure
  Function OpenWorkbook(ExcelApp,path)
  On Error Resume Next
  Set NewWorkbook =ExcelApp.Workbooks.Open(path)
  Set &#333;penWorkbook =NewWorkbook
  On Error GoTo 0
  End Function
  
  'The ActivateWorkbook methodsets one of the workbooks in the application as Activeworkbook
  'ExcelApp - the workbook'sparent excel Application
  'workbookIdentifier - the nameor the number of the workbook
  Sub ActivateWorkbook(ExcelApp,workbookIdentifier)
  On Error Resume Next
  ExcelApp.Workbooks(workbookIdentifier).Activate
  On Error GoTo 0
  End Sub
  
  'The CloseWorkbook methodcloses an open workbook
  'ExcelApp - the parent Excelapplication of the workbook
  'workbookIdentifier - the nameor the number of the workbook
  Sub CloseWorkbook(ExcelApp,workbookIdentifier)
  On Error Resume Next
  ExcelApp.Workbooks(workbookIdentifier).Close
  On Error GoTo 0
  End Sub
  
  'The CompareSheets methodcompares between two sheets.
  'if there is a differencebetween the two sheets then the value in the second sheet
  'will be changed to red andcontain the string:
  '"Compare conflict - Value was'Value2', Expected value is 'value2'"
  'sheet1, sheet2 - the excelsheets to be compared
  'startColumn - the column tostart comparing in the two sheets
  'numberOfColumns - the numberof columns to be compared
  'startRow - the row to startcomparing in the two sheets
  'numberOfRows - the number ofrows to be compared
  Function CompareSheets(sheet1,sheet2, startColumn, numberOfColumns, startRow, numberOfRows,trimed) 'As Boolean
  Dim returnVal 'As Boolean
  returnVal = True
  
  'In case that one of the sheetsdoesn't exists, don't continue the process
  If sheet1 Is Nothing Or sheet2Is Nothing Then
  CompareSheets = False
  Exit Function
  End If
  
  'loop through the table andfill values into the two worksheets
  For r = startRow to (startRow +(numberOfRows - 1))
  For c = startColumn to(startColumn + (numberOfColumns - 1))
  Value1 = sheet1.Cells(r,c)
  Value2 = sheet2.Cells(r,c)
  
  'if 'trimed' equels True thenused would like to ignore blank spaces
  If trimed Then
  Value1 = Trim(Value1)
  Value2 = Trim(Value2)
  End If
  
  'in case that the values of acell are not equel in the two worksheets
  'create an indicator that thevalues are not equel and set return value
  'to False
  If Value1<> Value2 Then
  Dim cell 'As Excel.Range
  sheet2.Cells(r, c) = "Compareconflict - Value was '" & Value2 &"', Expected value is '" & Value1 &"'."
  Set cell = sheet2.Cells(r,c)
  cell.Font.Color = vbRed
  returnVal = False
  End If
  Next
  Next
  CompareSheets = returnVal
  End Function