' 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