ExcelUtil Excel库函数

relevantcodes发布了一个名为ExcelUtil的Excel库，封装了Excel的常用操作，方便于QTP的Excel数据读写：

http://relevantcodes.com/excelutil-class-library-excel-utility-methods/

引用了这个ExcelUtil库之后，可以像如下代码使用：

'Example 1
ExcelUtil.SetFile "C:\Student.xls", "Sheet1"
 
'Example 2:  Reading value directly from a file
sCellValue = ExcelUtil.SetFile("C:\Student.xls", "Sheet1").GetCellValue(1, 1)
 
'Example 3:  Reading values from 2 different files - Approach 1
ExcelUtil.SetFile "C:\Student.xls", "Sheet1"
var1 = ExcelUtil.GetCellValue(1, 1)
ExcelUtil.SetFile "C:\Teacher.xls", "Sheet1"
var2 = ExcelUtil.GetCellValue(1, 1)
 
'Example 4:  Reading values from 2 different files - Approach 2
var1 = ExcelUtil.SetFile("C:\Student.xls", "Sheet1").GetCellValue(1, 1)
var2 = ExcelUtil.SetFile("C:\Teacher.xls", "Sheet1").GetCellValue(1, 1)

库函数文件的代码比较多，如下所示：

''' <file>RelevantCodes.ExcelUtil.cls.vbs</file>
''' <author>Anshoo Arora</author>
''' <company>Relevant Codes</company>
''' <copyright>Relevant Codes</copyright>
''' <version>1.0</version>
Option Explicit

''' <summary>
''' Global ExcelApplication (Excel.Application) object reference
''' Note: The global instance is destroyed through ExcelUtil.Destroy()
''' </summary>
''' <remarks></remarks>
Public ExcelApplication

'Root Namespace RelevantCodes

''' <summary>
''' Private Class [RelevantCodes.ExcelUtil]
''' </summary>
''' <remarks></remarks>
Class [RelevantCodes.ExcelUtil]

'Private Variables
 
 ''' <summary>
    ''' Range object created in FindCellContainingValue and passed to FindNextCell
    ''' </summary>
    ''' <remarks></remarks>
 Private rngFound
 
 ''' <summary>
    ''' Region Excel.Application instance created in Class_Initialize
    ''' </summary>
    ''' <remarks></remarks>
 Private xlsApp
 
 ''' <summary>
    ''' Region Excel WorkBook instance created in SetFile
    ''' </summary>
    ''' <remarks></remarks>
    ''' <seealso>SetFile()</seealso>
 Private xlsBook
 
 ''' <summary>
    ''' Region Excel WorkSheet instance created in SetFile
    ''' </summary>
    ''' <remarks></remarks>
 Private xlsSheet
 
 ''' <summary>
    ''' WorkBook path
    ''' </summary>
    ''' <remarks></remarks>
 Private sWorkBook
 
 ''' <summary>
    ''' WorkSheet name
    ''' </summary>
    ''' <remarks></remarks>
 Private sWorkSheet

'Public Properties
 
 ''' <summary>
    ''' Sets the region instances for Excel WorkBook and WorkSheet. These instances for the
 ''' Excel source are created only once and used by other methods.
 ''' NOTE: For any method to execute, SetFile must be executed first to set the WorkBook and WorkSheet.
    ''' </summary>
    ''' <param name="WorkBook" type="string">Path to the Excel WorkBook</param>
    ''' <param name="WorkSheet" type="string">Name or Item Number of the WorkSheet</param>
    ''' <returns>XLSUtil</returns>
 Public Property Get SetFile(ByVal WorkBook, ByVal WorkSheet)
  Dim fso

  Set SetFile = Me
  
  If xlsApp Is Nothing Then Exit Property
  
  'c#: this.sWorkBook = WorkBook;
  'vb: Me.sWorkBook = WorkBook
  If sWorkBook = "" Then sWorkBook = WorkBook
  'c#: this.sWorkSheet = WorkSheet;
  'vb: Me.sWorkSheet = WorkSheet
  If sWorkSheet = "" Then sWorkSheet = WorkSheet

  If sWorkBook <> WorkBook Then
   xlsBook.Close

   sWorkBook = WorkBook
  End If

  If sWorkSheet <> WorkSheet Then
   sWorkSheet = WorkSheet
  End If
  
  On Error Resume Next

   Set fso = CreateObject("Scripting.FileSystemObject")

   If Not fso.FileExists(WorkBook) Then
    MsgBox "Unable to find the Excel WorkBook with the given path: " & _
     WorkBook, vbOKOnly, "ExcelFile.SetFile->'File Not Found' Exception!"
    Set fso = Nothing
    Exit Property
   End If

   Set xlsBook = xlsApp.WorkBooks.Open(WorkBook)
   
   If Err.Number <> 0 Then
    MsgBox "Unable to load the WorkBook: " & WorkBook, vbOKOnly, _
     "SetFile->'xlsApp.WorkBooks.Open(WorkBook)' Exception!"
    Err.Clear
    Exit Property
   End If
   
   If Not IsNumeric(WorkSheet) Then
    Set xlsSheet = xlsBook.WorkSheets(WorkSheet)
   Else
    Set xlsSheet = xlsBook.WorkSheets.Item(WorkSheet)
   End If
   
   If Err.Number <> 0 Then
    MsgBox "Unable to bind to the WorkSheet: " & WorkSheet, vbOKOnly, _
     "ExcelUtil.SetFile->'xlsApp.WorkBooks.WorkSheets(Sheet)' Exception!"
    Err.Clear
    Exit Property
   End If
   
  On Error Goto 0
 End Property

 ''' <summary>
    ''' Returns a Scripting.Dictionary object with heading & row pair.
    ''' </summary>
    ''' <param name="iRow" type="integer">Data Row</param>
 ''' <param name="iHeadingRow" type="integer">Heading Row</param>
    ''' <returns>Scripting.Dictionary</returns>
 Public Property Get BuildRowHeadingDictionary(ByVal iRow, ByVal iHeadingRow)
  Dim oRange, arrRange, iColumns, dic, iCol
  
  Set oRange = GetWorkSheetRange
  arrRange = oRange.Value
  
  iColumns = UBound(oRange.Value, 2)
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  
  For iCol = LBound(arrRange, 2) To UBound(arrRange, 2)
   If Not dic.Exists(arrRange(1, iCol)) Then
    dic.Add CStr(arrRange(iHeadingRow, iCol)), CStr(arrRange(iRow, iCol))
   End If
  Next
  
  Set BuildRowHeadingDictionary = dic
 End Property

 ''' <summary>
    ''' Reads the value of a cell in an Excel WorkSheet
    ''' </summary>
    ''' <param name="iRow" type="integer">Row number</param>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <returns>String</returns>
 Public Property Get GetCellValue(ByVal iRow, ByVal vColumn)
  GetCellValue = xlsSheet.Cells(iRow, vColumn).Value
 End Property

 ''' <summary>
    ''' Returns the complete WorkSheet Range object
    ''' </summary>
    ''' <returns>Range</returns>
 Public Property Get GetWorkSheetRange()
  Set GetWorkSheetRange = xlsSheet.UsedRange
 End Property
 
 ''' <summary>
    ''' Returns a 2D array from the WorkSheet
    ''' </summary>
    ''' <returns>Array</returns>
 Public Property Get Get2DArrayFromSheet()
  Get2DArrayFromSheet = GetWorkSheetRange.Value
 End Property

 ''' <summary>
    ''' Returns a Range object if the supplied argument is found in the WorkSheet
    ''' </summary>
    ''' <param name="arg" type="variant">Value being searched for</param>
    ''' <returns>Range</returns>
 Public Property Get FindCellContainingValue(ByVal arg)
  Dim cell

  Set cell = xlsSheet.UsedRange.Find(arg)
  
  'c#: this.rngFound = cell;
  'vb: Me.rngFound = cell
  Set rngFound = cell

  Set FindCellContainingValue = cell
 End Property

 ''' <summary>
    ''' Finds the next cell from the supplied argument in FindCellContainingValue
    ''' </summary>
    ''' <returns>Range</returns>
 ''' <seealso>FindCellContainingValue</seealso>
 Public Property Get FindNextCell()
  Dim cell

  Set cell = xlsSheet.UsedRange.FindNext(rngFound)
  Set rngFound = cell

  Set FindNextCell = cell
 End Property
 
 ''' <summary>
    ''' Finds the number of used rows in the Excel WorkSheet
    ''' </summary>
    ''' <returns>Integer</returns>
 Public Property Get GetUsedRowCount()
  GetUsedRowCount = xlsSheet.UsedRange.Rows.Count
 End Property
 
 ''' <summary>
    ''' Finds the number of used columns in the Excel WorkSheet
    ''' </summary>
    ''' <returns>Integer</returns>
 Public Property Get GetUsedColumnCount()
  GetUsedColumnCount = xlsSheet.UsedRange.Columns.Count
 End Property
 
 ''' <summary>
    ''' Finds the number of used rows in an Excel WorkSheet by column
    ''' </summary>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <returns>Integer</returns>
 Public Property Get GetUsedRowCountByColumn(ByVal vColumn)
  Const xlDown = -4121
  
  GetUsedRowCountByColumn = xlsSheet.Cells(1, vColumn).End(xlDown).Row
 End Property
 
 ''' <summary>
    ''' Finds the number of used columns in an Excel WorkSheet by row
    ''' </summary>
    ''' <param name="iRow" type="integer">Row number</param>
    ''' <returns>Integer</returns>
 Public Property Get GetUsedColumnCountByRow(ByVal iRow)
  Const xlToRight = -4161
  
  GetUsedColumnCountByRow = xlsSheet.Cells(iRow, 1).End(xlToRight).Column
 End Property

'Public Methods
 
 ''' <summary>
    ''' Inputs a value to an Excel cell
    ''' </summary>
    ''' <param name="iRow" type="integer">Value input</param>
    ''' <param name="vColumn" type="variant">Row number</param>
    ''' <param name="TheValue" type="variant">Column letter or number</param>
    ''' <remarks></remarks>
 Public Sub WriteCellValue(ByVal TheValue, ByVal iRow, ByVal vColumn)
  If TheValue = "" Then Exit Sub
  
  xlsSheet.Cells(iRow, vColumn).Value = TheValue
  xlsBook.Save
 End Sub

 ''' <summary>
    ''' Inserts an image in a Excel cell
    ''' </summary>
    ''' <param name="iRow" type="integer">Row number</param>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <param name="ImagePath" type="string">Path to the image file</param>
    ''' <remarks></remarks>
 Public Sub InsertImageInCell(ByVal iRow, ByVal vColumn, ByVal ImagePath)
  Dim fso, pic

  Set fso = CreateObject("Scripting.FileSystemObject")

  If Not fso.FileExists(ImagePath) Then
   MsgBox "Unable to find the Image  with the given path: " & _
    ImagePath & ".", vbOKOnly, "ExcelUtil.InsertImageInCell->'File Not Found' Exception!"
   Set fso = Nothing
   Exit Sub
  End If
   
  xlsSheet.Cells(iRow, vColumn).Select

  With xlsSheet
   Set pic = .Pictures.Insert(ImagePath)

   With .Cells(iRow, vColumn)
    pic.top = .Top
    pic.left = .Left
   
    pic.ShapeRange.height = .RowHeight * 1
    pic.ShapeRange.width = .ColumnWidth * .ColumnWidth
   End With
  End With

  xlsBook.Save
 End Sub
 
 ''' <summary>
    ''' Changes the background color of a cell
    ''' </summary>
    ''' <param name="ColorCode" type="variant">Value of the custom color</param>
 ''' <param name="iRow" type="integer">Row number</param>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <remarks></remarks>
 Public Sub ChangeCellBGColor(ByVal ColorCode, ByVal iRow, ByVal vColumn)
  xlsSheet.Cells(iRow, vColumn).Interior.ColorIndex = ColorCode
  xlsBook.Save
 End Sub

 ''' <summary>
    ''' Changes the font color of a cell
    ''' </summary>
    ''' <param name="ColorCode" type="variant">Value of the custom color</param>
 ''' <param name="iRow" type="integer">Row number</param>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <remarks></remarks>
 Public Sub ChangeCellFontColor(ByVal ColorCode, ByVal iRow, ByVal vColumn)
  xlsSheet.Cells(iRow, vColumn).Font.ColorIndex = ColorCode
  xlsBook.Save
 End Sub
 
 ''' <summary>
    ''' Changes the font size
    ''' </summary>
    ''' <param name="iFontSize" type="integer">New font size</param>
 ''' <param name="iRow" type="integer">Row number</param>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <remarks></remarks>
 Public Sub ChangeFontSize(ByVal iFontSize, ByVal iRow, ByVal vColumn)
  xlsSheet.Cells(iRow, vColumn).Font.Size = iFontSize
  xlsBook.Save
 End Sub
 
 ''' <summary>
    ''' Draws a border to the left, right, top, or bottom of a given range
    ''' </summary>
    ''' <param name="Range" type="range">Excel Range</param>
    ''' <param name="Direction" type="variant">Direction: left, right, top, bottom</param>
    ''' <remarks></remarks>
 Public Sub DrawBorder(ByVal Range, ByVal Direction)
   If IsNumeric(Direction) Then Direction = CStr(Direction)

  Direction = LCase(Direction)
  
  With xlsSheet.Range(Range)
   Select Case Direction
    Case "1", "left"
     .Borders(1).LineStyle = 1
    Case "2", "right"
     .Borders(2).LineStyle = 1
    Case "3", "top"
     .Borders(3).LineStyle = 1
    Case "4", "bottom"
     .Borders(4).LineStyle = 1
    Case "5", "all"
     Dim ix     
     For ix = 1 To 4
      .Borders(ix).LineStyle = 1
     Next
    Case Else
     MsgBox "Invalid Direction: ' " & Direction & " '" & vbNewLine & _
      "Please provide the correct Direction to draw the border." & _
      Direction, vbOKOnly, "DrawBorder->'Invalid Direction' Exception!"
     Exit Sub
   End Select
  End With

  xlsBook.Save
 End Sub
 
 ''' <summary>
    ''' Merges the cells in a range
    ''' </summary>
    ''' <param name="Range" type="range">Excel Range</param>
    ''' <remarks></remarks>
 Public Sub MergeCells(ByVal Range)
   xlsApp.DisplayAlerts = False
   xlsSheet.Range(Range).MergeCells = True
  xlsApp.DisplayAlerts = True

  xlsBook.Save
 End Sub

 ''' <summary>
    ''' Removes the merge feature from cells of a given range
    ''' </summary>
    ''' <param name="Range" type="range">Excel Range</param>
    ''' <remarks></remarks>
 Public Sub UnmergeCells(ByVal Range)
   xlsApp.DisplayAlerts = False
   xlsSheet.Range(Range).MergeCells = False
  xlsApp.DisplayAlerts = True

  xlsBook.Save
 End Sub

 ''' <summary>
    ''' Inserts a hidden or visible comment in a cell
    ''' </summary>
    ''' <param name="CommentText" type="variant">Comment text</param>
    ''' <param name="iRow" type="integer">Row number</param>
    ''' <param name="vColumn" type="variant">Column letter or number</param>
    ''' <param name="bMakeVisible" type="bool">Make the comment visible or hidden</param>
    ''' <remarks></remarks>
 Public Sub InsertComment(ByVal CommentText, ByVal bMakeVisible, ByVal iRow, ByVal vColumn)
  With xlsSheet.Cells(iRow, vColumn)
   If Not .Comment Is Nothing Then .Comment.Delete
   
   .AddComment CommentText
   .Comment.Visible = bMakeVisible
  End With

  xlsBook.Save
 End Sub
 
 ''' <summary>
    ''' Creates and saves a new WorkBook for a given path
    ''' </summary>
    ''' <param name="WorkBookPath" type="string">Path of the Excel file</param>
    ''' <remarks></remarks>
 Public Sub CreateNewWorkBook(ByVal WorkBookPath, ByVal bReplaceOldFile)
  Dim fso
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  If fso.FileExists(WorkBookPath) Then
   If bReplaceOldFile Then
    fso.DeleteFile(WorkBookPath)
   Else
    Exit Sub
   End If
  End If
  
  Set xlsBook = xlsApp.Workbooks.Add
  xlsBook.SaveAs WorkBookPath
 End Sub
 
 ''' <summary>
    ''' Adds a WorkSheets to a given WorkBook
    ''' </summary>
    ''' <param name="WorkBook" type="string">Path to the Excel file</param>
    ''' <param name="WorkSheetName" type="string">New WorkSheet name</param>
    ''' <remarks></remarks>
 Public Sub AddWorkSheet(ByVal WorkBook, ByVal WorkSheetName)
  Dim fso, xlsBook, xlsSheet
  
  Set fso = CreateObject("Scripting.FileSystemObject")

  If Not fso.FileExists(WorkBook) Then
   MsgBox "Unable to find the Excel WorkBook with the given path: " & _
    WorkBook, vbOKOnly, "NewWorkSheet->'File Not Found' Exception!"
   Set fso = Nothing
   Exit Sub
  End If
  
  Set xlsBook = xlsApp.Workbooks.Open(WorkBook)
  
  For Each xlsSheet in xlsBook.WorkSheets
   If LCase(xlsSheet.Name) = LCase(WorkSheetName) Then Exit Sub
  Next
  
  Set xlsSheet = xlsBook.Worksheets.Add
  xlsSheet.Name = WorkSheetName
  xlsBook.Save
 End Sub

 ''' <summary>
    ''' Closes the WorkBook opened in SetFile
    ''' </summary>
    ''' <remarks></remarks>
 Public Sub CloseWorkBook()
  On Error Resume Next
   xlsBook.Close

   If Err.Number <> 0 Then Err.Clear
  On Error Goto 0
 End Sub

 ''' <summary>
    ''' Releases the global (ExcelApplication) Excel instance
    ''' </summary>
    ''' <remarks></remarks>
 Public Sub Destroy()
   ExcelApplication.Quit
  Set ExcelApplication = Nothing
 End Sub

'Private Methods

 ''' <summary>
    ''' Class Initialization procedure. Creates Excel Singleton.
    ''' </summary>
    ''' <remarks></remarks>
 Private Sub Class_Initialize()
  Dim bCreated : bCreated = False
  
  Set xlsApp = Nothing
  
  If IsObject(ExcelApplication) Then
   If Not ExcelApplication Is Nothing Then
    If TypeName(ExcelApplication) = "Application" Then
     bCreated = True
    End If
   End If
  End If
  
  If Not bCreated Then
   On Error Resume Next
    Set ExcelApplication = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
     Err.Clear

     Set ExcelApplication = CreateObject("Excel.Application")
    End If
    
    If Err.Number <> 0 Then
     MsgBox "Please install Excel before using ExcelUtil", vbOKOnly, "Excel.Application Exception!"
     Err.Clear
     Exit Sub
    End If
   On Error Goto 0
  End If
  
  Set xlsApp = ExcelApplication
 End Sub
 
 ''' <summary>
    ''' Class Termination procedure
    ''' </summary>
    ''' <remarks></remarks>
 Private Sub Class_Terminate()
  Set xlsApp = Nothing
  
  If IsObject(xlsBook) Then
   If Not xlsBook Is Nothing Then
    Set xlsBook = Nothing
   End If
  End If
  
  If IsObject(xlsSheet) Then
   If Not xlsSheet Is Nothing Then
    Set xlsSheet = Nothing
   End If
  End If
 End Sub

End Class

''' <summary>
''' ExcelUtil = RelevantCodes.ExcelUtil Class Instance
''' </summary>
Dim ExcelUtil : Set ExcelUtil = New [RelevantCodes.ExcelUtil]