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 =  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: \Testing\MyWorkbook.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(, sWorkbook, "\", vbTextCompare) >  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) <>  Then
            isWorkbookOpen = False
        End If
    Else
        'we have a short name
        If StrComp(Workbooks(sWorkbook).Name, sWorkbook, vbTextCompare) <>  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) =  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( ).Name
    'once again, but with feeling
    Debug.Print ThisWorkbook.Worksheets.Item( ).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 =  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 =  To UBound (avLinks)
            If StrComp(avLinks(nIndex), sOldLink, vbTextCompare) =  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 =  To UBound (avLinks)
        If StrComp(avLinks(nIndex), sLink, vbTextCompare) =  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 =  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().Range("TestEvents").Value = "Yes"
    Else
        ThisWorkbook.Worksheets().Range("TestEvents").Value = "No"
    End If
End Sub
 
Private Function UseEvents() As Boolean
    On Error Resume Next 
 
    UseEvents = False
    If UCase(ThisWorkbook.Worksheets().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  =  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