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