6 Workbook 对象

6.1 在奔跑之前先学会走路：打开和关闭工作薄

代码清单6.1：一个完整的工作薄批处理框架 

'代码清单6.1:一个完整的工作薄批处理框架 
Sub ProcessFileBatch() 
    Dim nIndex As Integer 
    Dim vFiles As Variant 
    Dim wb As Workbook 
    Dim bAlreadyOpen As Boolean 
     
    On Error GoTo ErrHandler 
     
    'Get a batch of Excel files 
    vFiles = GetExcelFiles("Select Workbooks for Processing" ) 
     
    'Make sure the dialog wasn't cancelled - in which case 
    'vFiles would equal False and therefore wouldn't be an array. 
    If Not IsArray(vFiles) Then 
        Debug.Print "No files Selected." 
        Exit Sub 
    End If 
     
    Application.ScreenUpdating = False 
     
    'OK - loop through the filenames 
    For nIndex = 1 To UBound (vFiles) 
     
        If isWorkbookOpen(CStr(vFiles(nIndex))) Then 
            Set wb = Workbooks(GetShortName(CStr (vFiles(nIndex)))) 
            Debug.Print "workbook already open: " & wb.Name 
            bAlreadyOpen = True 
             
        Else 
            Set wb = Workbooks.Open(CStr(vFiles(nIndex)), False ) 
            Debug.Print "Opened workbook: " & wb.Name 
            bAlreadyOpen = False 
             
        End If 
         
        Application.StatusBar = "processing workbook: " & wb.Name 
         
        'code to process the file goes here 
        Debug.Print "if we wanted to do something to the workbook, we would do it here" 
         
        'close workbook unless it was already open 
        If Not bAlreadyOpen Then 
            Debug.Print "closing workbook: " & wb.Name 
            wb.Close True 
        End If 
    Next nIndex 
     
    Set wb = Nothing 
ErrHandler: 
    Application.StatusBar = False 
    Application.ScreenUpdating = True 
     
End Sub 

6.2 工作薄打开了吗

代码清单6.2：查看一个工作薄是否是打开的 

'代码清单6.2: 查看一个工作薄是否是打开的 
' This function checks to see if a given workbook 
' is open or not. this function can be used 
' using a short name such as MyWorkbook.xls 
' or a full name such as C: TestingMyWorkbook.xls 
Function isWorkbookOpen(sWorkbook As String) As Boolean 
    Dim sName As String 
    Dim sPath As String 
    Dim sFullName As String 
     
    On Error Resume Next 
    isWorkbookOpen = True 
     
    'see if we were given a short name or a long name 
    If InStr(1, sWorkbook, "", vbTextCompare) > 0 Then 
        'we have a long name need to break it down 
        sFullName = sWorkbook 

        'BreakdownName参见代码清单5.8 
        BreakdownName sFullName, sName, sPath 
        If StrComp(Workbooks(sName).FullName, sWorkbook, vbTextCompare) <> 0 Then 
            isWorkbookOpen = False 
        End If 
    Else 
        'we have a short name 
        If StrComp(Workbooks(sWorkbook).Name, sWorkbook, vbTextCompare) <> 0 Then 
            isWorkbookOpen = False 
        End If 
    End If 
     
End Function 

另一个IsWorkbookOpen:

Function IsWorkbookOpen(sWorkbookName AsString) As Boolean 
    Dim wb As Workbook 
    
    IsWorkbookOpen = False 
    For Each wb In Workbooks 
        If StrComp(sWorkbookName, wb.Name, vbTextCompare) = 0 Then 
            IsWorkbookOpen = True 
            Exit Function 
        End If 
    Next 
    Set wb =Nothing 
End Function 

 三个VBA字符串函数：

InStr([start, ]string1, string2[, compare])： 指出string2在string1中第一次出现的位置。

InStrRev(string1, string2[, compare])： 指出string2在string1中最后一次出现的位置。

StrComp(string1, string2[, compare])： 比较两个字符串，返回-1、0、1中的值。

说明：

VBA中，字符串的索引是基于0的。

compare可以取值vbTextCompare或者vbBinaryCompare，前者表示不区分大小写，后者表示区分大小写。compare的默认值为vbUseCompareOption，就是取模块选项的设置。

6.2.1 指定特定的集合对象

下面的例子示范了可以指向集合中的一个项目的4种方法。这个例子使用Worksheets集合对象。

Sub ReferringToItems() 
    'refer to a worksheet by index number 
    Debug.Print ThisWorkbook.Worksheets(1 ).Name 
    'once again, but with feeling 
    Debug.Print ThisWorkbook.Worksheets.Item(1 ).Name 
     
    'refer to a worksheet by name 
    Debug.Print ThisWorkbook.Worksheets("Sheet1" ).Name 
    'and gain using item ... 
    Debug.Print ThisWorkbook.Worksheets.Item("Sheet1" ).Name 
     
End Sub

6.3以编程方式解开链接（第1部分）

代码清单6.3：以程序设计方式得到链接资源信息

'代码清单6.3:以程序设计方式得到链接资源信息 
Sub PrintSimpleLinkInfo(wb As Workbook) 
    Dim avLinks As Variant 
    Dim nIndex As Integer 
     
    'get list of excel based link sources 
    avLinks = wb.LinkSources(xlExcelLinks) 
    If Not IsEmpty(avLinks) Then 
        'loop through every link source 
        For nIndex = 1 To UBound (avLinks) 
            Debug.Print "link found to '" & avLinks(nIndex) & "'" 
        Next nIndex 
    Else 
        Debug.Print "the workbook '" & wb.Name & "' don't have any links." 
    End If 
     
End Sub

代码清单6.4：用新的文件位置更新链接

'代码清单6.4: 用新的文件位置更新链接 
Sub fixLinks(wb As Workbook, sOldLink As String, sNewLink As String ) 
    On Error Resume Next 
    wb.ChangeLink sOldLink, sNewLink, xlLinkTypeExcelLinks 
     
End Sub

代码清单6.5：用新的文件位置更新链接（一个替代过程）

'代码清单6.5: 用新的文件位置更新链接—一个替代过程 
Sub FixLinksII(wb As Workbook, sOldLink As String, sNewLink As String ) 
    Dim avLinks As Variant 
    Dim nIndex As Integer 
     
    'get a list of link sources 
    avLinks = wb.LinkSources(xlExcelLinks) 
     
    'if there are link sources, see if there are any named sOldLink     
    If Not IsEmpty(avLinks) Then 
        For nIndex = 1 To UBound (avLinks) 
            If StrComp(avLinks(nIndex), sOldLink, vbTextCompare) = 0 Then 
                'we have a match 
                 wb.ChangeLink sOldLink, sNewLink, xlLinkTypeExcelLinks 
                'once we find a match we won't find another, so exit the loop 
                Exit For 
            End If 
        Next 
    End If 

End Sub

代码清单6.6：链接状态查看器

'代码清单6.6: 链接状态查看器 
Function GetLinkStatus(wb As Workbook, sLink As String) As String 
    Dim avLinks As Variant 
    Dim nIndex As Integer 
    Dim sResult As String 
    Dim nStatus As Integer 
 
    'get a list of link sources 
    avLinks = wb.LinkSources(xlExcelLinks) 
     
    'make sure there are links in the workbook 
    If IsEmpty(avLinks) Then 
        GetLinkStatus = "No links in workbook." 
        Exit Function 
    End If 
     
    'default result in case the links is not found 
    sResult = "link not found" 
     
    For nIndex = 1 To UBound (avLinks) 
        If StrComp(avLinks(nIndex), sLink, vbTextCompare) = 0 Then 
            nStatus = wb.LinkInfo(sLink, xlLinkInfoStatus) 
             
            Select Case nStatus 
                Case xlLinkStatusCopiedValues 
                    sResult = "Copied values" 
                     
                Case xlLinkStatusIndeterminate 
                    sResult = "Indeterminnate" 
                     
                Case xlLinkStatusInvalidName 
                    sResult = "Invalid name" 
                     
                Case xlLinkStatusMissingFile 
                    sResult = "Missing file" 
                     
                Case xlLinkStatusMissingSheet 
                    sResult = "Missing sheet" 
                     
                Case xlLinkStatusNotStarted 
                    sResult = "Not started" 
                     
                Case xlLinkStatusOK 
                    sResult = "OK" 
                     
                Case xlLinkStatusOld 
                    sResult = "Old" 
                     
                Case xlLinkStatusSourceNotCalculated 
                    sResult = "Source Not Calculated" 
                     
                Case xlLinkStatusSourceNotOpen 
                    sResult = "Source Not Open" 
                     
                Case xlLinkStatusSourceOpen 
                    sResult = "Source Open" 
                     
                Case Else 
                    sResult = "Unknown status code" 
            End Select 
        End If 
    Next 
 
End Function

代码清单6.7：查看一个工作薄中所有的链接状态

'代码清单6.7: 查看一个工作薄中所有的链接状态 
Sub CheckAllLinks(wb As Workbook) 
    Dim avLinks As Variant 
    Dim nLinkIndex As Integer 
    Dim sMsg As String 
     
    avLinks = wb.LinkSources(xlExcelLinks) 
     
    If IsEmpty(avLinks) Then     
        Debug.Print wb.Name & " does not have any links." 
    Else 
        For nLinkIndex = 1 To UBound (avLinks) 
            Debug.Print "workbook: " & wb.Name 
            Debug.Print "link source: " & avLinks(nLinkIndex) 
            Debug.Print "status: " & GetLinkStatus(wb, CStr (avLinks(nLinkIndex))) 
        Next 
    End If 
      
End Sub

6.4 简单普通的工作薄属性

代码清单6.8：一个标准工作薄属性的简单例子

'代码清单6.8: 一个标准工作薄属性的简单例子 
Sub TestPrintGeneralWBInfo() 
    PrintGeneralWorkbookInfo ThisWorkbook
End Sub

Sub PrintGeneralWorkbookInfo(wb As Workbook) 
    Debug.Print "Name: " & wb.Name 
    Debug.Print "Full Name: " & wb.FullName 
    Debug.Print "Code Name: " & wb.CodeName 
    Debug.Print "File Format: " & GetFileFormat(wb) 
    Debug.Print "path: " & wb.Path 
     
    If wb.ReadOnly Then 
        Debug.Print " the workbook has been opened as read-only." 
    Else 
        Debug.Print " the workbook is read-write." 
    End If 
     
    If wb.Saved Then 
        Debug.Print "the workbook does not need to be saved." 
    Else 
        Debug.Print " the workbook should be saved." 
    End If 
End Sub 

Function GetFileFormat(wb As Workbook) As String 
    Dim lFormat As Long 
    Dim sFormat As String 
    lFormat = wb.FileFormat 
    Select Case lFormat 
        Case xlAddIn:   sFormat = "Add-In" 
         
        Case xlCSV:         sFormat = "CSV" 
        Case xlCSVMac:      sFormat = "CSV Mac" 
        Case xlCSVMSDOS:    sFormat = "CSV MSDOS" 
        Case xlCSVWindows:  sFormat = "CSV Windows" 
         
        Case xlCurrentPlatformText:  sFormat = "Current Platform Text" 
         
        Case xlDBF2:      sFormat = "DBF 2" 
        Case xlDBF3:      sFormat = "DBF 3" 
        Case xlDBF4:      sFormat = "DBF 4" 
         
        Case xlDIF:             sFormat = "xlDIF" 
        Case xlExcel2:          sFormat = "xlExcel2" 
        Case xlExcel2FarEast:   sFormat = "xlExcel2FarEast" 
        Case xlExcel3:          sFormat = "xlExcel3" 
        Case xlExcel4:          sFormat = "xlExcel4" 
        Case xlExcel4Workbook:  sFormat = "xlExcel4Workbook" 
        Case xlExcel5:          sFormat = "xlExcel5" 
        Case xlExcel7:          sFormat = "xlExcel7" 
        Case xlExcel9795:       sFormat = "xlExcel9795" 
         
        Case xlHtml:        sFormat = "xlHtml" 
        Case xlIntlAddIn:   sFormat = "xlIntlAddIn" 
        Case xlSYLK:        sFormat = "xlSYLK" 
        Case xlTemplate:    sFormat = "xlTemplate" 
        Case xlTextMac:     sFormat = "xlTextMac" 
        Case xlTextMSDOS:   sFormat = "xlTextMSDOS" 
        Case xlTextPrinter: sFormat = "xlTextPrinter" 
        Case xlTextWindows: sFormat = "xlTextWindows" 
        Case xlUnicodeText: sFormat = "xlUnicodeText" 
        Case xlWebArchive:  sFormat = "xlWebArchive" 
        Case xlWJ2WD1:      sFormat = "xlWJ2WD1" 
        Case xlWJ3:         sFormat = "xlWJ3" 
        Case xlWJ3FJ3:      sFormat = "xlWJ3FJ3" 
         
        Case xlWK1:              sFormat = "xlWK1" 
        Case xlWK1ALL:           sFormat = "xlWK1ALL" 
        Case xlWK1FMT:           sFormat = "xlWK1FMT" 
        Case xlWK3:              sFormat = "xlWK3" 
        Case xlWK3FM3:           sFormat = "xlWK3FM3" 
        Case xlWK4:              sFormat = "xlWK4" 
        Case xlWKS:              sFormat = "xlWKS" 
        Case xlWorkbookNormal:   sFormat = "xlWorkbookNormal" 
        Case xlWorks2FarEast:    sFormat = "xlWorks2FarEast" 
        Case xlWQ1:              sFormat = "xlWQ1" 
        Case xlXMLSpreadsheet:   sFormat = "xlXMLSpreadsheet" 
         
        Case Else 
            sFormat = "Unknown format code" 
    End Select 
    GetFileFormat = sFormat 
End Function

6.5 响应用户动作事件

代码清单6.9：测试Workbook对象事件 

Private Sub Workbook_Activate() 
    If UseEvents Then 
        MsgBox "Welcome back! ", vbOKOnly, "Activate Event" 
    End If
End Sub 

Private Sub Workbook_BeforeClose(Cancel As Boolean ) 
    Dim lResponse As Long 
     
    If UseEvents Then 
        lResponse = MsgBox("Thanks for visiting!" & "Are you sure you don't want to stick around?", vbYesNo, "see ya.." ) 
    End If     
End Sub 

Private Sub Workbook_Deactivate() 
    If UseEvents Then 
        MsgBox "see you soon...", vbOKOnly, "Deactivate Event" 
    End If
End Sub 

Private Sub Workbook_Open() 
    Dim lResponse As Long 
    lResponse = MsgBox("Welcome to the Chapter Six Example Workbook! Would you like to use events?", vbYesNo, "Welcome" ) 
     
    If lResponse = vbYes Then 
        TurnOnEvents True 
    ElseIf lResponse = vbNo Then 
        TurnOnEvents False
    End If
End Sub

Private Sub TurnOnEvents(bUseEvents As Boolean) 
    On Error Resume Next 
    If bUseEvents Then 
        ThisWorkbook.Worksheets(1).Range("TestEvents").Value = "Yes" 
    Else 
        ThisWorkbook.Worksheets(1).Range("TestEvents").Value = "No"     
    End If
End Sub

Private Function UseEvents() As Boolean 
    On Error Resume Next 
     
    UseEvents = False 
    If UCase(ThisWorkbook.Worksheets(1).Range("TestEvents").Value) = "YES" Then 
        UseEvents = True 
    End If
End Function

Private Sub Workbook_SheetActivate(ByVal Sh As Object) 
    If UseEvents Then 
        MsgBox "Activated " & Sh.Name, vbOKOnly, "SheetActivate Event" 
    End If     
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean ) 
    If UseEvents Then 
        MsgBox "Ouch! Stop that.", vbOKOnly, "SheetBeforeDoubleClick Event" 
    End If     
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean ) 
    If UseEvents Then 
        MsgBox "Right click " & Sh.Name & "; Target " & Target.Address & "; Cancel " & Cancel, vbOKOnly, "RightClick Event" 
    End If     
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 
    If UseEvents Then 
        MsgBox "You change the range" & Target.Address & " on " & Sh.Name, vbOKOnly, "Workbook_SheetChange Event" 
    End If     
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object ) 
    If UseEvents Then 
        MsgBox "Leaving " & Sh.Name, vbOKOnly, "Workbook_SheetDeactivate Event" 
    End If     
End Sub 

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) 
    If UseEvents Then     
        If Target.Row Mod 2 = 0 Then 
            MsgBox "I'm keeping my eyes on you! you selected the range " & Target.Address & " on " & Sh.Name, _ 
            vbOKOnly, "Workbook_SheetSelectionChange Event" 
        Else 
            MsgBox "you selected the range " & Target.Address & " on " & Sh.Name, _ 
            vbOKOnly, "Workbook_SheetSelectionChange Event"         
        End If      
    End If  
End Sub