5 Application 对象 - cuishengli

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

发表于 2014-02-25 19:22 cuishengli 阅读(310) 评论(0) 编辑收藏举报