进度表字符未按预期显示

Question

我正在尝试实现 'Status Bar Progress Meter' 我已经找到 here 并在我的代码中实现了它，如下所示：

Private Sub btnFetchFiles_Click()

    Dim j As Integer

        iRow = 20
        fPath = "\c\s\CAF1\Dragon Mentor Group\Dragon Scripts\Current\April 2015"
        If fPath <> "" Then

            ' make StatusBar visible
            Application.DisplayStatusBar = True
            Set FSO = New Scripting.FileSystemObject
            'First Message
            Application.StatusBar = String(5, ChrW(9609)) & " Working..."
            If FSO.FolderExists(fPath) <> False Then
                'Second Message
                Application.StatusBar = String(10, ChrW(9609)) & " Working..."
                Set SourceFolder = FSO.GetFolder(fPath)
                'Third Message
                Application.StatusBar = String(15, ChrW(9609)) & " Working..."
                IsSubFolder = True
                'Fourth Message
                Application.StatusBar = String(15, ChrW(9609)) & " Still Working..."
                Call DeleteRows
                If AllFilesCheckBox.Value = True Then
                'Fifth Message
                Application.StatusBar = String(15, ChrW(9609)) & " Still Working..."
                    Call ListFilesInFolder(SourceFolder, IsSubFolder)
                    Call ResultSorting(xlAscending, "C20")
                    Call FormatCells
                Else
                    Call ListFilesInFolderXtn(SourceFolder, IsSubFolder)
                    Call ResultSorting(xlAscending, "C20")
                    Call FormatCells
                End If
                'Sixth Message
                Application.StatusBar = String(20, ChrW(9609)) & "Still Working..."
                lblFCount.Caption = iRow - 20
                'Seventh Message
                Application.StatusBar = String(25, ChrW(9609)) & "Almost Done..."
            Else
                MsgBox "Selected Path Does Not Exist !!" & vbNewLine & vbNewLine & "Select Correct One and Try Again !!"
            End If
        Else
            MsgBox "Folder Path Can not be Empty !!" & vbNewLine & vbNewLine & ""
        End If
                'Eigth Message
                Application.StatusBar = String(30, ChrW(9609)) & "All Files Extracted..."
       'Relinquish the StatusBar
        Application.StatusBar = False
    End Sub

您将在下图中看到一个蓝色进度条运行ning 从左到右带有小矩形，

但是当我运行我的脚本时，我留下的不是小矩形而是一个连续的白色条，如下所示：

为什么？我哪里做错了？

Answer 1

如果您愿意，可以用百分比替换栏。我通常根据程序完成的过程来计算百分比。在您的情况下，您似乎正在为您的进度分配特定的值，这也很有效。

要实现，只需在您的代码中替换这一行即可：

Application.StatusBar = String(5, ChrW(9609)) & " Working..."

具有以下内容：

Application.StatusBar = "Working... 16% complete"

（16%，因为 5/30 来自您的代码）。

如果你想计算它，你可以这样做：

Application.StatusBar = "Working... " & Round(1 / 6 * 100, 0) & "%"

您可以根据需要用变量替换 1 和 6。

Answer 2

您期待的是蓝色 ▉▉▉▉▉，每个矩形符号 ▉ 之间有一个微小的窄间隙。

但是你变白了▉▉▉▉▉没有缝隙。

"why is this happening"的答案如下：只是字体不同而已！

显然 Excel 2013 字体是白色的，使矩形比 Excel 2010 字体稍微宽一点，这样间隙就消失了——而且矩形不是蓝色而是白色。

请注意，这绝不会妨碍进度条的功能。这只是审美和品味的问题——无论你喜欢蓝色还是白色，gaps or no gaps。

进度表字符未按预期显示

Progress Meter characters not displaying as intended

excel

vba

excel-2013