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: \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(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])： 比較兩個字符串，返回-一、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