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])： 比较两个字符串，返回-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
