5 Application 对象

5.1鸟瞰Application对象

5.2 必须了解的面向显示特性

5.2.1 使用ScreenUpdating改进和完善执行性能

代码清单5.1：实现屏幕更新的性能

'代码清单5.1: 实现屏幕更新的特性
Sub TimeScreenUpdating()
Dim dResult As Double

'test with screen updating turned on
dResult = TestScreenUpdating(True)
MsgBox Format(dResult, "0.00") & " seconds.", vbOKOnly

'test with screen updating turned off
dResult = TestScreenUpdating(False)
MsgBox Format(dResult, "0.00") & " seconds.", vbOKOnly

End Sub

Function TestScreenUpdating(bUpdatingOn As Boolean) As Double

'record the start time
Dim dStart As Double
dStart = Timer

'turn screen updating on or off
Application.ScreenUpdating = bUpdatingOn

'loop through each worksheet
'in the workbook 250 times
Dim nRepetition As Integer
Dim ws As Worksheet
For nRepetition = 1 To 250
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Next
Next

'turn screen updating on
Application.ScreenUpdating = True

'return elapsed time since procedure started
TestScreenUpdating = Timer - dStart

'clean up
Set ws = Nothing

End Function

5.2.2 使用状态栏为最终用户提供信息

代码清单5.2：使用StatusBar属性显示信息

'代码清单5.2: 使用StatusBar属性显示信息
'this subroutine tests the impact of
'using statusbar to display lots of frequent messages.
Sub TimeStatusBar()
Dim dStart As Double
Dim dResult As Double
Dim bDisplayStatusBar As Boolean

'remember original status bar setting
bDisplayStatusBar = Application.DisplayStatusBar
'turn on the status bar
Application.DisplayScrollBars = True

'baseline test - no status bar, every row
'to isolate how long it takes to
'perform mod statement on all rows
dStart = Timer
TestStatusBar 100, False
dResult = Timer - dStart
MsgBox Format(dResult, "0.00") & " Seconds.", vbOKOnly

'time using statusbar -every row
dStart = Timer
TestStatusBar 100, True
dResult = Timer - dStart
MsgBox Format(dResult, "0.00") & " Seconds.", vbOKOnly

'time using statusbar -every fifth row
dStart = Timer
TestStatusBar 500, True
dResult = Timer - dStart
MsgBox Format(dResult, "0.00") & " Seconds.", vbOKOnly

'restore the status bar to its original setting
Application.DisplayScrollBars = bDisplayStatusBar

End Sub

'this subroutine displays a message to the status bar
'(if desired) for each row in a worksheet using the
'interval specified.
Private Sub TestStatusBar(nInterval As Integer, bUseStatusBar As Boolean)
Dim lRow As Long
Dim lLastRow As Long
Dim ws As Worksheet

'using the first worksheet in this workbook
'no changes will be made to the worksheet.
Set ws = ThisWorkbook.Worksheets(1)

'every version since excel 97 has had
'65,536 rows. excel 5 had 16,384 rows.
lLastRow = ws.Rows.Count

For lRow = 1 To lLastRow

'test to see if the current row
'is the interval specified.
If lRow Mod nInterval = 0 Then
If bUseStatusBar Then
Application.StatusBar = "processing row: " & lRow & _
" of " & lLastRow & " rows."
End If
End If
Next

Application.StatusBar = False
Set ws = Nothing
End Sub

5.3 需要了解的面向显示特性

代码清单5.3：带有Cursor属性的可用光标

'代码清单5.3: 带有Cursor属性的可用光标
Sub ViewCursors()
Application.Cursor = xlNorthwestArrow
MsgBox "Do you like the xlNorthwestArrow? Hover over the worksheet to see it."

Application.Cursor = xlIBeam
MsgBox "How about xlIBeam? Hover over the worksheet to see it."

Application.Cursor = xlWait
MsgBox "How about xlWait? Hover over the worksheet to see it."

Application.Cursor = xlDefault
MsgBox "How about xlDefault? Hover over the worksheet to see it."

End Sub

代码清单5.4：示范各种面向窗口的属性

'代码清单5.4: 示范各种面向窗口的属性
Sub GetWindowInfo()
Dim lState As Long
Dim sInfo As String
Dim lResponse As Long

'Determine window state
lState = Application.WindowState
Select Case lState
Case xlMaximized
sInfo = "Window is maximized." & vbCrLf
Case xlMinimized
sInfo = "Window is maximized." & vbCrLf
Case xlNormal
sInfo = "window is normal." & vbCrLf
End Select

'prepare message to be displayed
sInfo = sInfo & "Usable Height = " & Application.UsableHeight & vbCrLf
sInfo = sInfo & "Usable Width = " & Application.UsableWidth & vbCrLf
sInfo = sInfo & "Height = " & Application.Height & vbCrLf
sInfo = sInfo & "Width = " & Application.Width & vbCrLf & vbCrLf

sInfo = sInfo & "Would you like to minimize it? " & vbCrLf

'Display message
lResponse = MsgBox(sInfo, vbYesNo, "")

'Minimize window if user clicked yes
If lResponse = vbYes Then
Application.WindowState = xlMinimized
End If

End Sub

5.4 便捷的Excel对象属性

属性	返回	描述
ActiveCell	Range
ActiveChart	Chart
ActivePrinter	String
ActiveSheet	Sheet
ActiveWindow	Window
ActiveWorkbook	Workbook
Selection	Range/Chart/Control	取决于用户的选择
ThisCell	Range	调用一个用户定义的函数单元格
ThisWorkbook	Workbook
Caller	Range	返回使用此函数的单元格

5.5 常用的简化文件操作

5.5.1从用户那里获得文件名

代码清单5.5：从用户那里获取单个工作薄

'代码清单5.5: 从用户那里获取单个工作薄
Sub TestGetFile()
Dim nIndex As Integer
Dim sFile As String

'Get a batch of Excel files
sFile = GetExcelFile("Testing GetExcelFile Function")

'make sure dialog wasn't cancelled - in which case
'sFile would equal False
If sFile = "False" Then
Debug.Print "No file selected."
Exit Sub
End If

'OK - we have a valid file
Debug.Print sFile

End Sub

'Presents user with a GetOpenFileName dialog which allows
'single file selection.
'return a single of filename
Function GetExcelFile(sTitle As String) As String

Dim sFilter As String
Dim bMultiSelect As Boolean

sFilter = "Workbooks (*.xls),*.xls"
bMultiSelect = False

GetExcelFile = Application.GetOpenFilename _
(FileFilter:=sFilter, Title:=sTitle, MultiSelect:=bMultiSelect)

End Function

代码清单5.6：从用户那里获取一批工作薄

'代码清单5.6: 从用户那里获取一批工作薄
Sub TestGetFiles()
Dim nIndex As Integer
Dim vFiles As Variant

'Get a batch of Excel files
vFiles = GetExcelFiles("Testing GetExcelFiles Function")

'make sure dialog wasn't cancelled - in which case
'vFiles would equal False
If Not IsArray(vFiles) Then
Debug.Print "No files selected."
Exit Sub
End If

'OK - loop through the fileNames
For nIndex = 1 To UBound(vFiles)
Debug.Print vFiles(nIndex)
Next nIndex

End Sub

'Presents user with a GetOpenFileName dialog that allows
'Multiple file selection.
'Returns an array of filenames.
Function GetExcelFiles(sTitle As String) As Variant
Dim sFilter As String
Dim bMultiSelect As Boolean

sFilter = "Workbooks (*.xls), *.xls "
bMultiSelect = True

GetExcelFiles = Application.GetOpenFilename _
(filefilter:=sFilter, Title:=sTitle, MultiSelect:=bMultiSelect)

End Function

默认情况下，VBA数组是基于0的。但是，GetOpenFilename多选模式返回的数组是基于1的。

5.5.2 使用GetSaveAsFilename选取合适的位置

代码清单5.7：GetSaveAsFilename的基本使用

'代码清单5.7: GetSaveAsFilename 的基本使用
Sub SimpleGetSaveAsFilename()
Dim sFile As String
Dim lResponse As Long
Dim sMsg As String

Do
sFile = Application.GetSaveAsFilename
sMsg = "you chose:  " & sFile & " . Keep experimenting?"
lResponse = MsgBox(sMsg, vbYesNo)

Loop While lResponse = vbYes

End Sub

5.5.2.1 分解文件名

代码清单5.8：分解文件名为路径和文件名

'代码清单5.8: 分解文件名为路径和文件名
'A simple procedure for testing the
'BreakDownName procedure
Sub TestBreakdownName()
Dim sPath As String
Dim sName As String

Dim sFileName As String
Dim sMsg As String

sFileName = Application.GetSaveAsFilename
BreakdownName sFileName, sName, sPath
sMsg = "the file name is:  " & sName & vbCrLf
sMsg = sMsg & "the path is:  " & sPath & vbCrLf

MsgBox sMsg, vbOKOnly

End Sub

Function GetShortName(sLongName As String) As String
Dim sPath As String
Dim sShortName As String

BreakdownName sLongName, sShortName, sPath
GetShortName = sShortName

End Function

'当有2个返回值时，用byRef参数过程
Sub BreakdownName(sFullName As String, ByRef sName As String, ByRef sPath As String)
Dim nPos As Integer

'Find out where the filename begins
nPos = FileNamePosition(sFullName)
If nPos > 0 Then
sName = Right(sFullName, Len(sFullName) - nPos)
sPath = Left(sFullName, nPos - 1)
Else
'invalid sFullName - don't change anything
End If

End Sub

'Returns the position or index of the first
'character of the filename given a full name
'A full name consists of a path and a filename
'Ex. FileNamePosition("c: \Testing\Test.txt") = 11
Function FileNamePosition(sFullName As String) As Integer
Dim bFound As Boolean
Dim nPosition As Integer

bFound = False
nPosition = Len(sFullName)

Do While bFound = False
If nPosition = 0 Then Exit Do

If Mid(sFullName, nPosition, 1) = "\" Then
bFound = True
Else
nPosition = nPosition - 1
End If
Loop

If bFound = False Then
FileNamePosition = 0
Else
FileNamePosition = nPosition
End If

End Function

5.6 检查操作环境

代码清单5.9：使用Application对象属性获取有效的系统信息

'代码清单5.9:使用Application 对象属性获取有效的系统信息
Sub InspectTheEnvironment()
Debug.Print Application.CalculationVersion
'    Debug.Print Application.MemoryFree
'    Debug.Print Application.MemoryUsed
Debug.Print Application.OperatingSystem
Debug.Print Application.OrganizationName
Debug.Print Application.UserName
Debug.Print Application.Version

End Sub

5.7有用的两个额外成员

第一个是CutCopyMode属性，这个属性决定当剪切或复制时，是否在选中区域边界周围显示移动的破折号。

Application.CutCopyMode = False

第二个功能是InputBox方法：

'5.7 InputBox 函数用法的例子
Sub SimpleInputBox()
Dim vInput As Variant
vInput = InputBox("What is your name?", "introduction", Application.UserName)
MsgBox "Hello, " & vInput & ". Nice to meet you.", vbOKOnly, "Introduction"

End Sub