VBA 进度条（2）

1.前提

1-1. 在VBA编辑器找到工具-引用-勾选MicroSoft Visual Basic for Applications Extensibility Library
1-2. 信任中心 -> 宏设置 -> 开发人员宏设置 -> 选中“信任对VBA工程对象模型的访问”

2.类模块

Private objApp                  As Object
Private uForm                   As Object
Private lbl1                    As Object
Private lbl2                    As Object
Private FormName                As String

Private Const GWL_STYLE         As Long = (-16)
Private Const WS_CAPTION        As Long = &HC00000
Private Const BarLength         As Long = 300

#If Win64 Then
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Sub Class_Initialize()
    t = Timer
    ms = t - Int(t)
    FormName = "FORM" & Format(Now, "yyyymmddhhmmss") & Replace(ms, ".", "")
End Sub

Public Sub ShowBar()
    CreateProgressBar
End Sub

Public Sub DestroyBar()
    If uForm Is Nothing Then
        Exit Sub
    End If
    Unload uForm
    RemoveModual FormName
    Set uForm = Nothing
    Set objApp = Nothing
End Sub

Public Sub ChangeProcessBarValue(value As Double, Optional message As String = "")
On Error Resume Next

    lbl1.Width = Int(value * BarLength)
    lbl2.Caption = IIf(message = "", Format(value, "恑搙丗0.00%"), message)
    DoEvents
    
End Sub

Public Sub SleepBar(ms As Long)
    Sleep ms
End Sub

Private Sub CreateProgressBar()

    Dim UsForm  As Object
    
    If InStr(1, Application.Name, "Word") > 0 Then
        Set objApp = ThisDocument
    ElseIf InStr(1, Application.Name, "Excel") > 0 Then
        Set objApp = ThisWorkbook
    End If

    RemoveModual FormName
    
    Set UsForm = objApp.VBProject.VBComponents.Add(vbext_ct_MSForm)
    With UsForm
        .Properties("Caption") = "UserForm"
        .Properties("Name") = FormName
        .Properties("Height") = 30
        .Properties("Width") = BarLength
        .Properties("BackColor") = RGB(240, 240, 240)
        .Properties("SpecialEffect") = fmSpecialEffectFlat
        .Properties("BorderStyle") = fmBorderStyleNone
    End With

    Set uForm = VBA.UserForms.Add(FormName)
    
    With uForm
        Set lbl1 = .Controls.Add("Forms.Label.1", "Label1", True)
        With lbl1
            .Left = 0
            .Top = 12
            .Height = 12
            .Width = 0
            .Caption = ""
            .BackColor = RGB(0, 0, 255)
            .BorderStyle = fmBorderStyleNone
            .BackStyle = fmBackStyleOpaque
            .BorderColor = .BackColor
            .ZOrder 1
        End With
        
        Set lbl2 = .Controls.Add("Forms.Label.1", "Label1", True)
        With lbl2
            .Left = 0
            .Top = 0
            .Height = 12
            .Width = BarLength
            .Caption = ""
            .TextAlign = fmTextAlignLeft
            .Font.Size = 9
            .Font.Bold = False
            .Font.Italic = False
            .Font.Name = "Meiryo UI"
            .ForeColor = RGB(0, 0, 0)
            .BorderStyle = fmBorderStyleNone
            .BackStyle = fmBackStyleTransparent
            .ZOrder 0
        End With
        
        RemoveFormCaption uForm
        uForm.Show vbModeless
        
    End With
    
End Sub

Private Sub RemoveModual(n As String)
On Error Resume Next
    objApp.VBProject.VBComponents.Remove objApp.VBProject.VBComponents(n)
    objApp.Save
End Sub


Private Sub RemoveFormCaption(FORM As Object)

    If Val(Application.Version) < 9 Then
        hwnd = FindWindow("ThunderXFrame", FORM.Caption)
    Else
        hwnd = FindWindow("ThunderDFrame", FORM.Caption)
    End If
    IStyle = GetWindowLong(hwnd, GWL_STYLE)
    IStyle = IStyle And Not WS_CAPTION
    SetWindowLong hwnd, GWL_STYLE, IStyle
    DrawMenuBar hwnd
    
End Sub

3.测试代码

Sub Process()
    Dim i As Long
    Dim pb As New ProcessBar
    
    Dim intSum, intCount As Long
    
    intSum = 256
    intCount = 0
    
    pb.ShowBar
    
    For i = 1 To intSum
        pb.SleepBar (100)
        intCount = intCount + 1
        pb.ChangeProcessBarValue (intCount / intSum)
    Next i
    
     Stop
    
    pb.DestroyBar
    
    
End Sub

4.运行效果