VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsProgBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Based on post by Michel Pierron
'http://groups.google.com/groups?selm=OigAf7KREHA.4016@TK2MSFTNGP12.phx.gbl
'Got from http://vangelder.orcon.net.nz/excel/progressbar.html
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WM_USER = &H400
Private Const PBM_SETPOS = WM_USER + 2
Private Const PBM_SETBARCOLOR = WM_USER + 9
Private Const PBS_SMOOTH = 1

Private Const cProgressWidth = 200
Private Const cProgressLeft = 200

Private prgText    As String
Private prgMin     As Long
Private prgMax     As Long
Private prgValue   As Long

Private hWnd       As Long
Private flgPrep    As Boolean

Private blnStatusBar As Boolean, i As Long, rctS As RECT

Public Property Let Text(vText As String)
    prgText = vText
End Property

Public Property Let Min(vMin As Long)
    prgMin = vMin
End Property

Public Property Get Min() As Long
    Min = prgMin
End Property

Public Property Let Max(vMax As Long)
    prgMax = vMax
End Property

Public Property Get Max() As Long
    Max = prgMax
End Property

Public Property Let Value(vVal As Long)
    prgValue = vVal
End Property

Public Property Get Value() As Long
    Value = prgValue
End Property

Private Sub Class_Initialize()
    prgMax = 100
    prgMin = 0
    prgValue = 0
    flgPrep = False
End Sub

Private Sub Prepare()
    hWnd = FindWindowEx(FindWindow(vbNullString, Application.Caption), 0, "EXCEL4", vbNullString)
    GetClientRect hWnd, rctS
    hWnd = CreateWindowEX(0, "msctls_progress32", "", WS_CHILD Or WS_VISIBLE Or PBS_SMOOTH, cProgressLeft, rctS.Top + 3, cProgressWidth, (rctS.Bottom - rctS.Top) - 6, hWnd, 0, 0, 0)
    SendMessage hWnd, PBM_SETBARCOLOR, 0, ByVal RGB(49, 106, 197)

    blnStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Application.StatusBar = ""
    flgPrep = True
End Sub

Public Sub ShowProgress()
    If prgValue <= prgMax Then
        If Not flgPrep Then Prepare
        Application.StatusBar = prgText & ", " & Format(prgValue / prgMax, "0%")
        SendMessage hWnd, PBM_SETPOS, (prgValue / prgMax) * 100, 0
        DoEvents
    End If
End Sub

Private Sub Class_Terminate()
    DestroyWindow hWnd
    Application.StatusBar = False
    Application.DisplayStatusBar = blnStatusBar
    flgPrep = False
End Sub