Question

我有从网上获得的Excel VBA代码，该代码列出了文件夹中的所有文件。我的问题是我想要进度指示器来提示用户该宏仍在运行。

代码在这里...

Private Sub CommandButton1_Click()
Worksheets("GetFileList").Unprotect 'Unprotect Sheet
    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$
    InitialFoldr$ = "C:\"
    Worksheets("GetFileList").Range("A4:a5000").Clear 'Clear selected range
    ActiveSheet.Range("a4").Select               'Set Focus

    With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    If .SelectedItems.Count <> 0 Then
             xDirect$ = .SelectedItems(1) & "\"
             xFname$ = Dir(xDirect$, 7)
        Do While xFname$ <> ""
            ActiveCell.Offset(xRow) = xFname$
            xRow = xRow + 1
            xFname$ = Dir
           Loop
        End If
        End With
Worksheets("GetFileList").Protect UserInterfaceOnly:=True
MsgBox "Done Processing...!"
End Sub

Answer 1

我使用以下经过改进的类以满足自己的需求。

因此在Excel的状态栏中看起来像这样：

button()

添加一个新的类模块，并使用以下代码将其命名为ProgressBar：

Option Explicit

Private statusBarState As Boolean
Private enableEventsState As Boolean
Private screenUpdatingState As Boolean
Private Const NUM_BARS As Integer = 50
Private Const MAX_LENGTH As Integer = 255
Private CharBar As String
Private CharSpace As String
Private CharStart As String
Private CharEnd As String

Private Sub Class_Initialize()
    ' Save the state of the variables to change
    statusBarState = Application.DisplayStatusBar
    enableEventsState = Application.EnableEvents
    screenUpdatingState = Application.ScreenUpdating
    ' set the progress bar chars (should be equal size)
    CharBar = ChrW(9608)
    CharSpace = ChrW(9617) 'ChrW(12288)
    CharStart = ChrW(9621)
    CharEnd = ChrW(9615)

    ' Set the desired state
    Application.DisplayStatusBar = True
'    Application.ScreenUpdating = False
'    Application.EnableEvents = False
End Sub

Private Sub Class_Terminate()
    ' Restore settings
    Application.DisplayStatusBar = statusBarState
    Application.ScreenUpdating = screenUpdatingState
    Application.EnableEvents = enableEventsState
    Application.StatusBar = False
End Sub

Public Function Update(ByVal Value As Long, _
                  Optional ByVal MaxValue As Long = 0, _
                  Optional ByVal Status As String = "", _
                  Optional ByVal StatusEnd As String = "", _
                  Optional ByVal DisplayPercent As Boolean = True) As String

    ' Value          : 0 to 100 (if no max is set)
    ' Value          : >=0 (if max is set)
    ' MaxValue       : >= 0
    ' Status         : optional message to display for user
    ' DisplayPercent : Display the percent complete after the status bar

    ' <Status> <Progress Bar> <Percent Complete>

    ' Validate entries
    If Value < 0 Or MaxValue < 0 Or (Value > 100 And MaxValue = 0) Then Exit Function

    ' If the maximum is set then adjust value to be in the range 0 to 100
    If MaxValue > 0 Then Value = WorksheetFunction.RoundUp((Value * 100) / MaxValue, 0)

    ' Message to set the status bar to
    Dim Display As String
    Display = Status & "  " & CharStart

    ' Set bars
    Display = Display & String(Int(Value / (100 / NUM_BARS)), CharBar)
    ' set spaces
    Display = Display & String(NUM_BARS - Int(Value / (100 / NUM_BARS)), CharSpace)

    ' Closing character to show end of the bar
    Display = Display & CharEnd

    If DisplayPercent = True Then Display = Display & "  (" & Value & "%)  "

    Display = Display & "  " & StatusEnd

    ' chop off to the maximum length if necessary
    If Len(Display) > MAX_LENGTH Then Display = Right(Display, MAX_LENGTH)

    Update = Display
    Application.StatusBar = Display
End Function

在您现有的代码中按以下方式使用它：

Option Explicit

Sub TestProgressBar()
    Dim Progress As New ProgressBar

    Dim i As Long
    For i = 1 To 10
        Progress.Update i, 10, "Some Text before", "SomeTextAfter", True
        Application.Wait (Now + TimeValue("0:00:01"))
    Next i
End Sub

上面的代码是在此处找到的原始代码的改进版本：

Excel VBA进度指示器

1 个答案: