'代码清单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 =  To

        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: 使用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 , False

    dResult = Timer - dStart

    MsgBox Format(dResult, "0.00") & " Seconds.", vbOKOnly

    'time using statusbar -every row

    dStart = Timer

    TestStatusBar , True

    dResult = Timer - dStart

    MsgBox Format(dResult, "0.00") & " Seconds.", vbOKOnly

    'time using statusbar -every fifth row

    dStart = Timer

    TestStatusBar , 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()

    'every version since excel 97 has had

    '65,536 rows. excel 5 had 16,384 rows.

    lLastRow = ws.Rows.Count

    For lRow =  To lLastRow

        'test to see if the current row

        'is the interval specified.

        If lRow Mod nInterval =  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: 带有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: 示范各种面向窗口的属性

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.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: 从用户那里获取一批工作薄

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 =  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

'代码清单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.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 >  Then

        sName = Right(sFullName, Len(sFullName) - nPos)

        sPath = Left(sFullName, nPos - )

    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 =  Then Exit Do

        If Mid(sFullName, nPosition, ) = "\" Then

            bFound = True

        Else

            nPosition = nPosition -

        End If

    Loop

    If bFound = False Then

        FileNamePosition =

    Else

        FileNamePosition = nPosition

    End If

End Function

'代码清单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

Application.CutCopyMode = False

'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