VBA Excel Statusbar...Change Colors? 3

[Jdoggers]

Hi,
I have made a statusbar in my excel macro to tell the progress so far. I was wondering if there was any way to change the color of the statusbar font to another color...say red for example. Can anyone help me?

code used for statusbar

application.statusbar = "Please wait..."

I would like for the 'Please wait' to show up in red color instead of black

thanks in advance
j

 

[rmikesmith]

j,

There is no way to do this using Excel itself, as there is no Statusbar object exposed, merely a Statusbar property, which you are already using. If you are using Excel 2000 or later, it would be easy to create your own "pop-up" message while the macro is running (e.g. a small, modeless userform with customized text & properties).


Regards,
Mike

 

[PBAPaul]

Hi J

You might be interested in faq707-5032 which allows you to put up a message box for a specific amount of time or until an action is finished.

Paul

 

[petroffp]

Usually I launch my macros with an application specific dialogue box. On the dialogue are two controls
1. frmProgress (a frame )
2. lblProgress (a text lable inside the frame)

At design time or load set
lblprogress.backcolor= Some contrasting color
lblprogress.width = 0

During the processing of the macro periodically make calls to UpdateProgress(pct), where pct is the percent complete.

Sub UpdateProgress(pct)
    lblProgress.Width = pct * (frmProgress.Width - 1)
    Me.Repaint
End Sub

The me.repaint repaints the entire dialogue which is not optimal, but it works.

 

[combo]

Hi,
As most in windows, the excel status bar can be configured with API. Below the class code, rather long, that warps up the status bar and configures it, and a sample use in a module. The code authors' names are listed in class comments, I have not recorded the web site address.

class module 'clsProgressBar'

' Originally written and copyrighted by David Wiseman.
' Edited by Jim Rech to make it work with Excel 2000.
' Converted to a class module by Ole P. Erlandsen

Option Explicit
'   API wrappers for calling from 16/32 bit VBA
'   portions Copyright David Wiseman 1996
' Type definitions
Private Type RECT16   '8 Bytes
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
End Type

Private Type RECT32   '16 Bytes
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type SIZE16   '4 Bytes
    cx As Integer
    cy As Integer
End Type

Private Type SIZE32   '8 Bytes
    cx As Long
    cy As Long
End Type

Private Type LOGFONT16   ' 50 Bytes
    lfHeight As Integer
    lfWidth As Integer
    lfEscapement As Integer
    lfOrientation As Integer
    lfWeight As Integer
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type

Private Type LOGFONT32
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type

' API declarations
Private Declare Function GetActiveWindow16 Lib "USER" Alias "GetActiveWindow" () As Integer
Private Declare Function GetActiveWindow32 Lib "USER32" Alias "GetActiveWindow" () As Long

Private Declare Function SystemParametersInfo16 Lib "USER" Alias "SystemParametersInfo" (ByVal uAction As Integer, ByVal uParam As Integer, lpvParam As Any, ByVal fuWinIni As Integer) As Integer
Private Declare Function SystemParametersInfo32 Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Declare Function GetSysColor16 Lib "USER" Alias "GetSysColor" (ByVal nIndex As Integer) As Long
Private Declare Function GetSysColor32 Lib "USER32" Alias "GetSysColor" (ByVal nIndex As Long) As Long

Private Declare Sub GetClientRect16 Lib "USER" Alias "GetClientRect" (ByVal hWnd As Integer, lpRect As RECT16)
Private Declare Function GetClientRect32 Lib "USER32" Alias "GetClientRect" (ByVal hWnd As Long, lpRect As RECT32) As Long

Private Declare Function GetDC16 Lib "USER" Alias "GetDC" (ByVal hWnd As Integer) As Integer
Private Declare Function GetDC32 Lib "USER32" Alias "GetDC" (ByVal hWnd As Long) As Long

Private Declare Function SaveDC16 Lib "GDI" Alias "SaveDC" (ByVal hdc As Integer) As Integer
Private Declare Function SaveDC32 Lib "GDI32" Alias "SaveDC" (ByVal hdc As Long) As Long

Private Declare Function RestoreDC16 Lib "GDI" Alias "RestoreDC" (ByVal hdc As Integer, ByVal nSavedDC As Integer) As Integer
Private Declare Function RestoreDC32 Lib "GDI32" Alias "RestoreDC" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long

Private Declare Function ReleaseDC16 Lib "USER" Alias "ReleaseDC" (ByVal hWnd As Integer, ByVal hdc As Integer) As Integer
Private Declare Function ReleaseDC32 Lib "USER32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare Sub InvalidateRect16 Lib "USER" Alias "InvalidateRect" (ByVal hWnd As Integer, lpRect As RECT16, ByVal bErase As Integer)
Private Declare Function InvalidateRect32 Lib "USER32" Alias "InvalidateRect" (ByVal hWnd As Long, lpRect As RECT32, ByVal bErase As Long) As Long

Private Declare Function GetWindow16 Lib "USER" Alias "GetWindow" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
Private Declare Function GetWindow32 Lib "USER32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wCmd As Long) As Long

Private Declare Function GetClassName16 Lib "USER" Alias "GetClassName" (ByVal hWnd As Integer, ByVal className As String, ByVal maxCount As Integer) As Integer
Private Declare Function GetClassName32 Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nmaxCount As Long) As Long

Private Declare Function CreateFontIndirect16 Lib "GDI" Alias "CreateFontIndirect" (lpLogFont As LOGFONT16) As Integer
Private Declare Function CreateFontIndirect32 Lib "GDI32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT32) As Long

Private Declare Function SelectObject16 Lib "GDI" Alias "SelectObject" (ByVal hdc As Integer, ByVal hObject As Integer) As Integer
Private Declare Function SelectObject32 Lib "GDI32" Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject16 Lib "GDI" Alias "DeleteObject" (ByVal hObject As Integer) As Integer
Private Declare Function DeleteObject32 Lib "GDI32" Alias "DeleteObject" (ByVal hObject As Long) As Long

Private Declare Function SetBkColor16 Lib "GDI" Alias "SetBkColor" (ByVal hdc As Integer, ByVal RGB As Long) As Long
Private Declare Function SetBkColor32 Lib "GDI32" Alias "SetBkColor" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function SetTextColor16 Lib "GDI" Alias "SetTextColor" (ByVal hdc As Integer, ByVal RGB As Long) As Long
Private Declare Function SetTextColor32 Lib "GDI32" Alias "SetTextColor" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function GetTextExtentPoint16 Lib "GDI" Alias "GetTextExtentPoint" (ByVal hdc As Integer, ByVal text As String, ByVal lenText As Integer, lpSize As SIZE16) As Integer
Private Declare Function GetTextExtentPoint32 Lib "GDI32" Alias "GetTextExtentPointA" (ByVal hdc As Long, ByVal lpszString As String, ByVal cbString As Long, lpSize As SIZE32) As Long

Private Declare Function CreateSolidBrush16 Lib "GDI" Alias "CreateSolidBrush" (ByVal RGB As Long) As Integer
Private Declare Function CreateSolidBrush32 Lib "GDI32" Alias "CreateSolidBrush" (ByVal crColor As Long) As Long

Private Declare Function PatBlt16 Lib "GDI" Alias "PatBlt" (ByVal hdc As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal deROP As Long) As Integer
Private Declare Function PatBlt32 Lib "GDI32" Alias "PatBlt" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function FrameRect16 Lib "USER" Alias "FrameRect" (ByVal hdc As Integer, lpRect As RECT16, ByVal hBrush As Integer) As Integer
Private Declare Function FrameRect32 Lib "USER32" Alias "FrameRect" (ByVal hdc As Long, lpRect As RECT32, ByVal hBrush As Long) As Long

Private Declare Function DrawText16 Lib "USER" Alias "DrawText" (ByVal hdc As Integer, ByVal text As String, ByVal nCount As Integer, lpRect As RECT16, ByVal wFormat As Integer) As Integer
Private Declare Function DrawText32 Lib "USER32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT32, ByVal wFormat As Long) As Long

' API Constants
Private Const GW_CHILD As Integer = 5
Private Const GW_HWNDFIRST As Integer = 0
Private Const GW_HWNDNEXT As Integer = 2

Private Const DT_SINGLELINE As Integer = &H20
Private Const DT_CENTER As Integer = &H1
Private Const DT_VCENTER As Integer = &H4
Private Const DT_NOPREFIX As Integer = &H800
Private Const DT_NOCLIP As Integer = &H100

Private Const SPI_GETICONTITLELOGFONT As Integer = 31

Private Const PATCOPY As Long = &HF00021

Private Const COLOR_ACTIVECAPTION As Integer = 2
Private Const COLOR_BTNTEXT As Integer = 18
Private Const COLOR_BTNHIGHLIGHT As Integer = 20
Private Const COLOR_BTNSHADOW As Integer = 16
Private Const COLOR_BTNFACE As Integer = 15

Private m_hDeviceContext As Long                 ' handle of the Device Context

Private m_UserStatusBar As Boolean          ' store users preference for status bar view

Private m_numberOfLEDs As Long              ' number of LEDs in the bar
Private m_preMessage As String              ' message before the LED Bar
Private m_postMessage As String             ' message after the LED Bar
Private m_percentComplete As Long           ' the current LED Bar % alight

Private m_hWndXLStatus As Long              ' handle for Excel Status Bar window
Private m_hDCXLStatus As Long               ' handle to device context in that window

Private m_LEDBarShowing As Boolean          ' set when the LED Bar is displayed
Private m_LEDsAlight As Long                ' number of LED blocks displayed now
Private XLBar As RECT32                     ' the bounding rectangle for the Excel status bar window
Private XLBarSize As SIZE32                 ' the extent of the Excel status bar window
Private StatusFont As LOGFONT32             ' structure for font info from system
   
Private ACTIVECAPTION As Long               ' colours from the system
Private BTNTEXT As Long
Private BTNHIGHLIGHT As Long
Private BTNSHADOW As Long
Private BTNFACE As Long

Private RGB_LEDBarBG As Long                ' colours of various parts of LED Bar and text
Private RGB_LEDBarFG As Long
Private RGB_StatusBG As Long
Private RGB_preMessageBG As Long
Private RGB_preMessageFG As Long
Private RGB_postMessageBG As Long
Private RGB_postMessageFG As Long
Private RGB_highlightTopLeft As Long
Private RGB_highlightBottomRight As Long

Private LEDBlock As RECT32                  ' the bounding rectangle for a single LED
Private LEDBlockSize As SIZE32              ' the extent of a single LED block
Private LEDSpace As Long                    ' the space between succesive LEDs
   
Private LEDBar As RECT32                    ' the bounding rectangle for the LED indicator strip
Private LEDBarSize As SIZE32                ' the extent of the LED indicator strip

Private preMessageBox As RECT32             ' bounds of the Message before the LED Bar
Private postMessageBox As RECT32            ' bounds of the Message after the LED Bar

' Initialise what needs it
Private Property Let OpenDC(hWnd As Long)
    m_hDeviceContext = GetDC(hWnd)              ' Get a device context to draw into
    Call SaveDC(m_hDeviceContext)               ' Save state for later
End Property

' Tidy up when we are done
Private Property Let CloseDC(hWnd As Long)
    Call RestoreDC(m_hDeviceContext, -1)        ' Restore the DC state to where we found it
    Call ReleaseDC(hWnd, m_hDeviceContext)      ' Release this DC handle
End Property

' Draw some text to the device context
Private Sub DrawWindowText(cFG As Long, cBG As Long, Font As LOGFONT32, text As String, rC As RECT32)
  Dim hFont As Long
  Dim textSize As SIZE32
  Dim textDrawFlags As Long
  
    hFont = CreateFontIndirect(Font)                    ' Create a font and get a handle on it
    hFont = SelectObject(m_hDeviceContext, hFont)       ' Select new font into the DC
    Call SetBkColor(m_hDeviceContext, cBG)              ' Background colour
    Call SetTextColor(m_hDeviceContext, cFG)            ' Foreground colour

                                                        ' Make room for the text
    Call GetTextExtentPoint(m_hDeviceContext, text, Len(text), textSize)
    rC.Right = rC.Left + textSize.cx
                                                ' Flags for normal text draw mode
    textDrawFlags = DT_SINGLELINE Or DT_CENTER Or _
                    DT_VCENTER Or DT_NOPREFIX Or DT_NOCLIP
    Call DrawText(m_hDeviceContext, text, -1, rC, textDrawFlags)      ' Draw the text

    hFont = SelectObject(m_hDeviceContext, hFont)            ' Select original font into the DC
    Call DeleteObject(hFont)                    ' Delete new font
End Sub

' Clear a rectangle
Private Sub RectangleClear(rC As RECT32, RGB As Long)
  Dim hBrush As Long
  Dim rS As SIZE32
    rS = GetSize(rC)                            ' size of rectangle
    hBrush = CreateSolidBrush(RGB)              ' Create a solid brush to paint rectangle
    hBrush = SelectObject(m_hDeviceContext, hBrush)          ' Select new brush into the DC
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Top, rS.cx, rS.cy, PATCOPY)    ' Do the clear
    hBrush = SelectObject(m_hDeviceContext, hBrush)          ' Select original brush into the DC
    Call DeleteObject(hBrush)                   ' Delete new brush
End Sub

' Frame a rectangle in one colour
Private Sub RectangleFrame(rC As RECT32, RGB As Long)
  Dim hBrush As Long
    hBrush = CreateSolidBrush(RGB)              ' Create a solid brush to paint frame
    Call FrameRect(m_hDeviceContext, rC, hBrush)             ' Do the frame
End Sub

' Frame a rectangle in two colours
Private Sub RectangleHighlight(rC As RECT32, TopLeftRGB As Long, BottomRightRGB As Long)
    Call RectanglePaintTopLeft(rC, TopLeftRGB)
    Call RectanglePaintBottomRight(rC, BottomRightRGB)
End Sub

' Highlight Top and Left sides of a rectangle
Private Sub RectanglePaintTopLeft(rC As RECT32, RGB As Long)
  Dim hBrush As Long
  Dim rS As SIZE32
    rS = GetSize(rC)                            ' size of rectangle
    hBrush = CreateSolidBrush(RGB)              ' Create a solid brush to paint sides
    hBrush = SelectObject(m_hDeviceContext, hBrush)          ' Select new brush into the DC
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Top, 1, rS.cy, PATCOPY)    ' Do the paint up left side
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Top, rS.cx, 1, PATCOPY)    ' Do the paint across top
    hBrush = SelectObject(m_hDeviceContext, hBrush)          ' Select original brush into the DC
    Call DeleteObject(hBrush)                   ' Delete new brush
End Sub

' Highlight Bottom and Right sides of a rectangle
Private Sub RectanglePaintBottomRight(rC As RECT32, RGB As Long)
  Dim hBrush As Long
  Dim rS As SIZE32
    rS = GetSize(rC)                            ' size of rectangle
    hBrush = CreateSolidBrush(RGB)              ' Create a solid brush to paint sides
    hBrush = SelectObject(m_hDeviceContext, hBrush)          ' Select new brush into the DC
    Call PatBlt(m_hDeviceContext, rC.Right, rC.Top, 1, rS.cy + 1, PATCOPY)  ' Do the paint up right side
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Bottom, rS.cx + 1, 1, PATCOPY) ' Do the paint across bottom
    hBrush = SelectObject(m_hDeviceContext, hBrush)          ' Select original brush into the DC
    Call DeleteObject(hBrush)                   ' Delete new brush
End Sub

Private Function GetActiveWindow() As Long
    If Engine32() Then
        GetActiveWindow = GetActiveWindow32()
    Else
        GetActiveWindow = GetActiveWindow16()
    End If
End Function

Private Function IconTitleFont() As LOGFONT32
  Dim fontInfo32 As LOGFONT32
  Dim fontInfo16 As LOGFONT16
    If Engine32() Then
        Call SystemParametersInfo32(SPI_GETICONTITLELOGFONT, Len(fontInfo32), fontInfo32, 0)
    Else
        Call SystemParametersInfo16(SPI_GETICONTITLELOGFONT, Len(fontInfo16), fontInfo16, 0)
        fontInfo32 = ConvertToFontInfo32(fontInfo16)
    End If
    
    IconTitleFont = fontInfo32
    
End Function

Private Function GetSysColor(nIndex As Long) As Long
    If Engine32() Then
        GetSysColor = GetSysColor32(nIndex)
    Else
        GetSysColor = GetSysColor16(nIndex)
    End If
End Function

Private Function ClientRectangle(hWnd As Long) As RECT32
  Dim aRect32 As RECT32
    If Engine32() Then
        Dim stat32 As Long
        stat32 = GetClientRect32(hWnd, aRect32)
    Else
        Dim aRect16 As RECT16
        Call GetClientRect16(hWnd, aRect16)
        aRect32 = ConvertToRect32(aRect16)
    End If
    ClientRectangle = aRect32
End Function

Private Function GetDC(hWnd As Long) As Long
    If Engine32() Then
        GetDC = GetDC32(hWnd)
    Else
        GetDC = GetDC16(hWnd)
    End If
End Function

Private Function SaveDC(hdc As Long) As Long
    If Engine32() Then
        SaveDC = SaveDC32(hdc)
    Else
        SaveDC = SaveDC16(hdc)
    End If
End Function

Private Function RestoreDC(hdc As Long, nSavedDC As Long) As Long
    If Engine32() Then
        RestoreDC = RestoreDC32(hdc, nSavedDC)
    Else
        RestoreDC = RestoreDC16(hdc, nSavedDC)
    End If
End Function

Private Function ReleaseDC(hWnd As Long, hdc As Long) As Long
    If Engine32() Then
        ReleaseDC = ReleaseDC32(hWnd, hdc)
    Else
        ReleaseDC = ReleaseDC16(hWnd, hdc)
    End If
End Function

Private Sub InvalidateRect(hWnd As Long, aRect32 As RECT32, bErase As Long)
    If Engine32() Then
        Dim stat32 As Long
        stat32 = InvalidateRect32(hWnd, aRect32, bErase)
    Else
        Dim aRect16 As RECT16
        aRect16 = ConvertToRect16(aRect32)
        Call InvalidateRect16(hWnd, aRect16, bErase)
    End If
End Sub

Private Function GetWindow(hWnd As Long, wCmd As Long) As Long
    If Engine32() Then
        GetWindow = GetWindow32(hWnd, wCmd)
    Else
        GetWindow = GetWindow16(hWnd, wCmd)
    End If
End Function

Private Function GetClassName(hWnd As Long, lpClassName As String, nmaxCount As Long) As Long
    If Engine32() Then
        GetClassName = GetClassName32(hWnd, lpClassName, nmaxCount)
    Else
        GetClassName = GetClassName16(hWnd, lpClassName, nmaxCount)
    End If
End Function

Private Function CreateFontIndirect(fontInfo32 As LOGFONT32) As Long
    If Engine32() Then
        CreateFontIndirect = CreateFontIndirect32(fontInfo32)
    Else
        Dim fontInfo16 As LOGFONT16
        fontInfo16 = ConvertToFontInfo16(fontInfo32)
        CreateFontIndirect = CreateFontIndirect16(fontInfo16)
    End If
End Function

Private Function SelectObject(hdc As Long, hObject As Long) As Long
    If Engine32() Then
        SelectObject = SelectObject32(hdc, hObject)
    Else
        SelectObject = SelectObject16(hdc, hObject)
    End If
End Function

Private Function DeleteObject(hObject As Long) As Long
    If Engine32() Then
        DeleteObject = DeleteObject32(hObject)
    Else
        DeleteObject = DeleteObject16(hObject)
    End If
End Function

Private Function SetBkColor(hdc As Long, RGB As Long) As Long
    If Engine32() Then
        SetBkColor = SetBkColor32(hdc, RGB)
    Else
        SetBkColor = SetBkColor16(hdc, RGB)
    End If
End Function

Private Function SetTextColor(hdc As Long, RGB As Long) As Long
    If Engine32() Then
        SetTextColor = SetTextColor32(hdc, RGB)
    Else
        SetTextColor = SetTextColor16(hdc, RGB)
    End If
End Function

Private Function GetTextExtentPoint(hdc As Long, text As String, lenText As Long, aSize32 As SIZE32) As Long
    If Engine32() Then
        GetTextExtentPoint = GetTextExtentPoint32(hdc, text, lenText, aSize32)
    Else
        Dim aSize16 As SIZE16
        GetTextExtentPoint = GetTextExtentPoint16(hdc, text, lenText, aSize16)
        aSize32 = ConvertToSize32(aSize16)
    End If
End Function

Private Function CreateSolidBrush(RGB As Long) As Long
    If Engine32() Then
        CreateSolidBrush = CreateSolidBrush32(RGB)
    Else
        CreateSolidBrush = CreateSolidBrush16(RGB)
    End If
End Function

Private Function PatBlt(hdc As Long, x As Long, y As Long, nWidth As Long, nHeight As Long, deROP As Long) As Long
    If Engine32() Then
        PatBlt = PatBlt32(hdc, x, y, nWidth, nHeight, deROP)
    Else
        PatBlt = PatBlt16(hdc, x, y, nWidth, nHeight, deROP)
    End If
End Function

Private Function FrameRect(hdc As Long, aRect32 As RECT32, hBrush As Long) As Long
    If Engine32() Then
        FrameRect = FrameRect32(hdc, aRect32, hBrush)
    Else
        Dim aRect16 As RECT16
        aRect16 = ConvertToRect16(aRect32)
        FrameRect = FrameRect16(hdc, aRect16, hBrush)
    End If
End Function

Private Function DrawText(hdc As Long, text As String, nCount As Long, aRect32 As RECT32, wFormat As Long) As Long
    If Engine32() Then
        DrawText = DrawText32(hdc, text, nCount, aRect32, wFormat)
    Else
        Dim aRect16 As RECT16
        aRect16 = ConvertToRect16(aRect32)
        DrawText = DrawText16(hdc, text, nCount, aRect16, wFormat)
    End If
End Function

' Conversion functions
Private Function ConvertToRect16(aRect32 As RECT32) As RECT16
    ConvertToRect16.Top = aRect32.Top
    ConvertToRect16.Left = aRect32.Left
    ConvertToRect16.Bottom = aRect32.Bottom
    ConvertToRect16.Right = aRect32.Right
End Function

Private Function ConvertToRect32(aRect16 As RECT16) As RECT32
    ConvertToRect32.Top = aRect16.Top
    ConvertToRect32.Left = aRect16.Left
    ConvertToRect32.Bottom = aRect16.Bottom
    ConvertToRect32.Right = aRect16.Right
End Function

Private Function ConvertToSize16(aSize32 As SIZE32) As SIZE16
    ConvertToSize16.cx = aSize32.cx
    ConvertToSize16.cy = aSize32.cy
End Function

Private Function ConvertToSize32(aSize16 As SIZE16) As SIZE32
    ConvertToSize32.cx = aSize16.cx
    ConvertToSize32.cy = aSize16.cy
End Function

Private Function ConvertToFontInfo16(fontInfo32 As LOGFONT32) As LOGFONT16
    ConvertToFontInfo16.lfHeight = fontInfo32.lfHeight
    ConvertToFontInfo16.lfWidth = fontInfo32.lfWidth
    ConvertToFontInfo16.lfEscapement = fontInfo32.lfEscapement
    ConvertToFontInfo16.lfOrientation = fontInfo32.lfOrientation
    ConvertToFontInfo16.lfWeight = fontInfo32.lfWeight
    ConvertToFontInfo16.lfItalic = fontInfo32.lfItalic
    ConvertToFontInfo16.lfUnderline = fontInfo32.lfUnderline
    ConvertToFontInfo16.lfStrikeOut = fontInfo32.lfStrikeOut
    ConvertToFontInfo16.lfCharSet = fontInfo32.lfCharSet
    ConvertToFontInfo16.lfOutPrecision = fontInfo32.lfOutPrecision
    ConvertToFontInfo16.lfClipPrecision = fontInfo32.lfClipPrecision
    ConvertToFontInfo16.lfQuality = fontInfo32.lfQuality
    ConvertToFontInfo16.lfPitchAndFamily = fontInfo32.lfPitchAndFamily
    ConvertToFontInfo16.lfFaceName = fontInfo32.lfFaceName
End Function

Private Function ConvertToFontInfo32(fontInfo16 As LOGFONT16) As LOGFONT32
    ConvertToFontInfo32.lfHeight = fontInfo16.lfHeight
    ConvertToFontInfo32.lfWidth = fontInfo16.lfWidth
    ConvertToFontInfo32.lfEscapement = fontInfo16.lfEscapement
    ConvertToFontInfo32.lfOrientation = fontInfo16.lfOrientation
    ConvertToFontInfo32.lfWeight = fontInfo16.lfWeight
    ConvertToFontInfo32.lfItalic = fontInfo16.lfItalic
    ConvertToFontInfo32.lfUnderline = fontInfo16.lfUnderline
    ConvertToFontInfo32.lfStrikeOut = fontInfo16.lfStrikeOut
    ConvertToFontInfo32.lfCharSet = fontInfo16.lfCharSet
    ConvertToFontInfo32.lfOutPrecision = fontInfo16.lfOutPrecision
    ConvertToFontInfo32.lfClipPrecision = fontInfo16.lfClipPrecision
    ConvertToFontInfo32.lfQuality = fontInfo16.lfQuality
    ConvertToFontInfo32.lfPitchAndFamily = fontInfo16.lfPitchAndFamily
    ConvertToFontInfo32.lfFaceName = fontInfo16.lfFaceName
End Function

Private Function GetSize(rC As RECT32) As SIZE32
    GetSize.cx = rC.Right - rC.Left
    GetSize.cy = rC.Bottom - rC.Top
End Function

' Get the window handle of a child window,
' given the parent handle, and the child class name
Private Function hWndOfChildFromClass(hWndTop As Long, requiredClassName As String) As Long
  Dim lenClassNameBuffer As Long
  Dim lenClassName As Long
  Dim aClassName As String * 7
  Dim hWndNext As Long
  
    lenClassNameBuffer = 7
    
    hWndNext = GetWindow(hWndTop, GW_CHILD)         ' get any child window
    hWndNext = GetWindow(hWndNext, GW_HWNDFIRST)    ' get the first child window
  
    lenClassName = GetClassName(hWndNext, aClassName, lenClassNameBuffer)   ' name of first child
    If (Left$(aClassName, 6) = Left$(requiredClassName, 6)) Then
        hWndOfChildFromClass = hWndNext             ' which could be the one we want
        Exit Function
    End If
    
    While hWndNext <> 0
        hWndNext = GetWindow(hWndNext, GW_HWNDNEXT) ' search all children
        lenClassName = GetClassName(hWndNext, aClassName, lenClassNameBuffer)
        If (Left$(aClassName, 6) = Left$(requiredClassName, 6)) Then
            hWndOfChildFromClass = hWndNext         ' to find the one we want
            Exit Function
        End If
    Wend
    
    hWndOfChildFromClass = hWndNext                 ' end of list, no children
    
End Function

Private Function Engine32() As Boolean
  Static engineIs32 As Boolean
  Static haveTested As Boolean
    If haveTested Then
        Engine32 = engineIs32
        Exit Function
    ElseIf InStr(Application.OperatingSystem, "32") Then
        engineIs32 = True
    End If
    haveTested = True
    Engine32 = engineIs32
End Function
  
' An object which functions as a LED indicator bar on the Excel Status Bar
' Copyright David Wiseman 1994, 1995, 1996
' Do the stuff which can be done once at start of program (behind the scenes)
Sub Initialize(numberOfLEDs As Long)
  Dim hWndParent As Long
  Dim XLBarCentre As Long
      
    m_numberOfLEDs = numberOfLEDs
      
    hWndParent = GetActiveWindow()

'   Get the handle of the EXCEL status bar window
'   MS changed the class name of the status bar, beginning with Excel 97
    'If Application.Version <> "8.0" Then ''David's original code that blocks running on Excel 2000
    If Val(Application.Version) < 8 Then
        m_hWndXLStatus = hWndOfChildFromClass(hWndParent, "EXCEL8")
    Else
        m_hWndXLStatus = hWndOfChildFromClass(hWndParent, "EXCEL4")
    End If
      
    If (m_hWndXLStatus <> 0) Then                   ' Proceed if handle valid
      
        XLBar = ClientRectangle(m_hWndXLStatus) ' Excel status bar rectangle
        XLBarSize.cx = XLBar.Right - XLBar.Left     ' and extents
        XLBarSize.cy = XLBar.Bottom - XLBar.Top
         
                                                    ' Use the same font as the screen icons
        StatusFont = IconTitleFont
                                                    ' But Excel likes it in 10 point!
        StatusFont.lfHeight = (StatusFont.lfHeight * 10) / 8
         
                                                    ' Colours of system components
        ACTIVECAPTION = GetSysColor(COLOR_ACTIVECAPTION)
        BTNTEXT = GetSysColor(COLOR_BTNTEXT)
        BTNHIGHLIGHT = GetSysColor(COLOR_BTNHIGHLIGHT)
        BTNSHADOW = GetSysColor(COLOR_BTNSHADOW)
        BTNFACE = GetSysColor(COLOR_BTNFACE)
         
        RGB_LEDBarBG = BTNFACE                  ' default colours of various parts of LED Bar and text
        RGB_LEDBarFG = ACTIVECAPTION
        RGB_StatusBG = BTNFACE
        RGB_preMessageBG = BTNFACE
        RGB_preMessageFG = BTNTEXT
        RGB_postMessageBG = BTNFACE
        RGB_postMessageFG = BTNTEXT
        RGB_highlightTopLeft = BTNSHADOW
        RGB_highlightBottomRight = BTNHIGHLIGHT
         
        XLBarCentre = XLBar.Top + XLBarSize.cy / 2
         
        LEDBlockSize.cx = XLBarSize.cy / 3          ' each LED is 1/3 height of status bar
        LEDBlockSize.cy = LEDBlockSize.cx           ' and square
        LEDSpace = XLBarSize.cy / 10                ' spacing = 1/10 height of status bar
         
        LEDBlock.Bottom = XLBarCentre + LEDBlockSize.cy / 2     ' bottom of each LED block
        LEDBlock.Top = LEDBlock.Bottom - LEDBlockSize.cy        ' top of each LED block
         
        LEDBar.Bottom = LEDBlock.Bottom + LEDSpace              ' bottom of the LED bar rectangle
        LEDBar.Top = LEDBlock.Bottom - LEDBlockSize.cy - LEDSpace  ' top of the LED bar rectangle
        LEDBarSize.cx = 2 * LEDSpace + numberOfLEDs * (LEDSpace + LEDBlockSize.cx) ' width of the LED bar
        LEDBarSize.cy = LEDSpace + LEDBlockSize.cy + LEDSpace   ' height of the LED bar

        preMessageBox = XLBar                       ' top and bottom = full bar (centered)
        postMessageBox = XLBar

        preMessageBox.Left = XLBar.Left + XLBarSize.cy / 2

    End If

End Sub

' Display a LED Bar with messages etc
Sub Show(PreMessage As String, PostMessage As String, thePctComplete As Long)
    
    m_preMessage = PreMessage
    m_postMessage = PostMessage
        
    If (m_hWndXLStatus <> 0) Then                   ' Proceed if handle valid
        
        m_UserStatusBar = Application.DisplayStatusBar
        Application.DisplayStatusBar = True
        Application.StatusBar = " "
                
        OpenDC = m_hWndXLStatus                 ' Establish a device context object
            
        Call RectangleClear(XLBar, RGB_StatusBG) ' Clear the entire Status Bar area
                                     
        Call DrawWindowText(RGB_preMessageFG, _
                               RGB_preMessageBG, _
                               StatusFont, _
                               m_preMessage, _
                               preMessageBox)    ' Display the pre LED Bar message
                                                    ' (returns dimensions of text box)

                                                    ' How big was the message ?
                                                    ' Sort out the other dimensions required
                                                    ' Place to start the LED bar
        LEDBar.Left = preMessageBox.Right + XLBarSize.cy / 2
        LEDBar.Right = LEDBar.Left + LEDBarSize.cx  ' and a place to end the LED bar

        postMessageBox.Left = LEDBar.Right + XLBarSize.cy / 2  ' place to start the post text

        Call DrawWindowText(RGB_postMessageFG, _
                               RGB_postMessageBG, _
                               StatusFont, _
                               m_postMessage, _
                               postMessageBox)         ' Display the post LED Bar message
                        
        Call RectangleClear(LEDBar, RGB_LEDBarBG) ' Clear the LED Bar area
        
        Call RectanglePaintTopLeft(XLBar, RGB_highlightBottomRight) ' Highlight top left as per usual
                                                             ' Excel status bars
        Call RectangleHighlight(LEDBar, _
                                   RGB_highlightTopLeft, _
                                   RGB_highlightBottomRight) ' Sunken look for LED bar surround
             
        CloseDC = m_hWndXLStatus                  ' Finished with the DC

        m_LEDsAlight = 0
        
        m_LEDBarShowing = True
        
        PercentComplete = thePctComplete                    ' update the LED Bar

    End If

End Sub

' Return the status bar to Excel
Sub Hide()
    If (m_hWndXLStatus <> 0) Then                   ' Proceed if handle valid
        Application.DisplayStatusBar = m_UserStatusBar
        Application.StatusBar = False
        Call InvalidateRect(m_hWndXLStatus, XLBar, True)
        m_LEDBarShowing = False
    End If
End Sub

' Update the message before the LED Bar
Property Let PreMessage(theMessage As String)
    m_preMessage = theMessage
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Update the message after the LED Bar
Property Let PostMessage(theMessage As String)
    m_postMessage = theMessage
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Update the number of LEDs alight
Property Let PercentComplete(thePercent As Long)
  Dim newBlocksDone As Long
  
    m_percentComplete = thePercent
    
    If (m_hWndXLStatus <> 0) And m_LEDBarShowing Then
                    
        If ((m_percentComplete > 0) And (m_percentComplete <= 100)) Then      ' In range for display
            
            newBlocksDone = (m_numberOfLEDs * m_percentComplete) / 100 ' Any change in number
            If (m_LEDsAlight <> newBlocksDone) Then             ' of blocks ?
                
                OpenDC = m_hWndXLStatus                 ' Establish a device context object
                                        
                While (m_LEDsAlight < newBlocksDone)
                    LEDBlock.Left = LEDBar.Left + (LEDBlockSize.cx / 2) + m_LEDsAlight * (LEDBlockSize.cx + LEDSpace)
                    LEDBlock.Right = LEDBlock.Left + LEDBlockSize.cx
                    Call RectangleClear(LEDBlock, RGB_LEDBarFG)
                    m_LEDsAlight = m_LEDsAlight + 1
                Wend

                While (m_LEDsAlight > newBlocksDone)
                    LEDBlock.Left = LEDBar.Left + (LEDBlockSize.cx / 2) + m_LEDsAlight * (LEDBlockSize.cx + LEDSpace)
                    LEDBlock.Right = LEDBlock.Left + LEDBlockSize.cx
                    Call RectangleClear(LEDBlock, RGB_LEDBarBG)
                    m_LEDsAlight = m_LEDsAlight - 1
                Wend
                                     
                CloseDC = m_hWndXLStatus                  ' Finished with the DC
            
            End If
        End If
    End If
End Property

' Change the LED Bar FG colour
Property Let ProgressBarFG_RGB(RGBColour As Long)
    RGB_LEDBarFG = RGBColour
    m_LEDsAlight = 0                                    ' refresh the LEDs in the Bar
    PercentComplete = m_percentComplete
End Property

' Change the LED Bar BG colour
Property Let ProgressBarBG_RGB(RGBColour As Long)
    RGB_LEDBarBG = RGBColour
    m_LEDsAlight = 0                                    ' refresh the LEDs in the Bar
    PercentComplete = m_percentComplete
End Property

' Change the Status area BG colour
Property Let StatusAreaBG_RGB(RGBColour As Long)
    RGB_StatusBG = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Change the preMessage FG colour
Property Let PreMessageFG_RGB(RGBColour As Long)
    RGB_preMessageFG = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Change the preMessage BG colour
Property Let PreMessageBG_RGB(RGBColour As Long)
    RGB_preMessageBG = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Change the postMessage FG colour
Property Let PostMessageFG_RGB(RGBColour As Long)
    RGB_postMessageFG = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Change the postMessage BG colour
Property Let PostMessageBG_RGB(RGBColour As Long)
    RGB_postMessageBG = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Change the TopLeft highlight colour
Property Let HighlightTopLeft_RGB(RGBColour As Long)
    RGB_highlightTopLeft = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

' Change the BottomRight highlight colour
Property Let HighlightBottomRight_RGB(RGBColour As Long)
    RGB_highlightBottomRight = RGBColour
    Call Show(m_preMessage, m_postMessage, m_percentComplete)
End Property

Private Sub Class_Initialize()
    Initialize 20
    ProgressBarFG_RGB = RGB(0, 0, 0) ' black
    'ProgressBarFG_RGB = RGB(0, 0, 255) ' blue
End Sub

Private Sub Class_Terminate()
    Hide ' hides the progressbar
End Sub

standard module

Sub ProgressBarAdvancedDemo()
Dim sb As clsProgressBar, i As Long
    Set sb = New clsProgressBar
    sb.Show "Please wait", "Initializing...", 0
    
    For i = 0 To 30 Step 5
        sb.PercentComplete = i
        WaitSeconds 1
    Next i
    
    sb.PreMessageFG_RGB = RGB(255, 255, 255)
    
    For i = 35 To 70 Step 5
        sb.PercentComplete = i
        WaitSeconds 1
    Next i
    sb.ProgressBarFG_RGB = RGB(255, 0, 0)
    sb.PreMessage = "Still doing nothing much"
    
    For i = 75 To 90 Step 5
        sb.PercentComplete = i
        WaitSeconds 1
    Next i
    
    sb.PostMessage = "Almost there!"
    
    For i = 95 To 100 Step 5
        sb.PercentComplete = i
        WaitSeconds 1
    Next i
    
    Set sb = Nothing
End Sub

Private Sub WaitSeconds(waitTime As Integer)
    Application.Wait (Now + TimeValue("00:00:" & Format(waitTime, "00")))
End Sub

combo

 

[TonyJollans]

Hi Jdoggers, combo,

A word or two about this code.
[ul][li]You must call the Class clsProgressBar for it to work.[/li][li]It does demonstrate that the status bar can be coloured, but hardly makes it easy for someone without good knowledge of the API to do it.[/li][li]A sample workbook is available from John Walkenbach (where else?) - see

http://www.j-walk.com/ss/excel/files/developer.htm

and look for the entry headed Control the LED Display in the StatusBar[/li][li]The code doesn't actually manipulate the Excel status bar itself. What it does is find out where it is and then hijacks that bit of screen for its own use - overwriting the Excel statusbar - very neat but, as I say, not exactly tailorable by the average Excel user.[/li][/ul]
The Excel status bar proper (indeed the status bar in all Office apps) is , AFAIK, completely unavailable (except via the very limited Application.StatusBar) - it doesn't even adjust according to Windows settings in the way that the status bar in other apps does - and should.

Enjoy,
Tony

--------------------------------------------------------------------------------------------
We want to help you; help us to do it by reading this: Before you ask a question.
Excel VBA Training and more Help at VBAExpress[