Option Explicit
Option Compare Binary
Option Base 0
Public Enum abOnCloseBehavior
abNoAction = 0
abRestore = 1
abUnrestrict = 2
abRestrict = 4
End Enum
Private Type StatusBar
Handle As Long
OriginalValue As Variant
VisibilityOriginal As Boolean
CurrentText As Variant
Progress As Long
End Type
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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Const m_lngNoValue_c As Long = 0
Private m_tStatusBar As StatusBar
Private objApp As Excel.Application
Private m_eOnClose As abOnCloseBehavior
Private m_blnOrgEnableEvents As Boolean
Private m_blnOrgDisplayAlerts As Boolean
Private m_blnScreenUpdating As Boolean
Private m_eEnableCancelKey As Excel.XlEnableCancelKey
Private m_eOrgCursor As Excel.XlMousePointer
Private Sub Class_Initialize()
On Error Resume Next
Set objApp = Excel.Application
Me.RecordCurrentSettings
m_tStatusBar.Progress = -1
m_eOnClose = abRestore
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Const m_lngNoValue_c As Long = 0
If (Me.OnClose And abOnCloseBehavior.abRestore) = abOnCloseBehavior.abRestore Then
Me.Restore
ElseIf (Me.OnClose And abOnCloseBehavior.abRestrict) = abOnCloseBehavior.abRestrict Then
Me.Restrict
ElseIf (Me.OnClose And abOnCloseBehavior.abUnrestrict) = abOnCloseBehavior.abUnrestrict Then
Me.Unrestrict
End If
If m_tStatusBar.Handle <> m_lngNoValue_c Then
Me.ProgressBarHide
End If
End Sub
Public Sub Unrestrict()
objApp.EnableEvents = True
objApp.DisplayAlerts = True
objApp.Cursor = xlDefault
objApp.StatusBar = False
objApp.ScreenUpdating = True
objApp.EnableCancelKey = xlInterrupt
End Sub
Public Sub Restore()
Const strFalse_c As String = "False"
Const lngMatch_c As Long = 0
objApp.ScreenUpdating = m_blnScreenUpdating
objApp.EnableEvents = m_blnOrgEnableEvents
objApp.DisplayAlerts = m_blnOrgDisplayAlerts
objApp.Cursor = m_eOrgCursor
objApp.EnableCancelKey = m_eEnableCancelKey
If VBA.StrComp(m_tStatusBar.OriginalValue, strFalse_c, vbTextCompare) = lngMatch_c Then
objApp.StatusBar = False
End If
objApp.DisplayStatusBar = m_tStatusBar.VisibilityOriginal
End Sub
Public Sub Restrict()
Const strDefaultMsg_c As String = "Working..."
objApp.Cursor = xlWait
objApp.DisplayAlerts = False
objApp.EnableEvents = False
objApp.EnableCancelKey = xlErrorHandler
objApp.StatusBar = False
objApp.DisplayStatusBar = True
objApp.StatusBar = strDefaultMsg_c
objApp.ScreenUpdating = False
End Sub
Public Sub RecordCurrentSettings()
Const strFalse_c As String = "FALSE"
Const lngMatch_c As Long = 0
m_blnScreenUpdating = objApp.ScreenUpdating
m_blnOrgEnableEvents = objApp.EnableEvents
m_blnOrgDisplayAlerts = objApp.DisplayAlerts
m_eOrgCursor = objApp.Cursor
m_eEnableCancelKey = objApp.EnableCancelKey
m_tStatusBar.OriginalValue = objApp.StatusBar
If VBA.StrComp(m_tStatusBar.OriginalValue, strFalse_c, vbTextCompare) = lngMatch_c Then
m_tStatusBar.OriginalValue = False
End If
m_tStatusBar.CurrentText = m_tStatusBar.OriginalValue
m_tStatusBar.VisibilityOriginal = objApp.DisplayStatusBar
End Sub
Public Property Get OnClose() As abOnCloseBehavior
OnClose = m_eOnClose
End Property
Public Property Let OnClose(NewValue As abOnCloseBehavior)
m_eOnClose = NewValue
End Property
Private Sub CreateProgressBar()
Const strClsNameStatusBar_c As String = "EXCEL4"
Const strClsNameLED_c As String = "msctls_progress32"
Const lngNoChild_c As Long = 0
Const WS_EX_LEFT As Long = 0
Const WS_CHILD As Long = 1073741824
Const WS_VISIBLE As Long = 268435456
Const lngNoMatch_c As Long = 0
Dim lngStatusBarHandle As Long
Dim lngPrgrssBarHandle As Long
lngStatusBarHandle = FindWindowEx(Excel.Application.hwnd, lngNoChild_c, strClsNameStatusBar_c, vbNullString)
lngPrgrssBarHandle = FindWindowEx(lngStatusBarHandle, lngNoChild_c, strClsNameLED_c, vbNullString)
If lngPrgrssBarHandle = lngNoMatch_c Then
m_tStatusBar.Handle = CreateWindowEx(WS_EX_LEFT, strClsNameLED_c, vbNullString, _
WS_VISIBLE + WS_CHILD, 300, 2, 350, 14, lngStatusBarHandle, 0, 0, 0)
Else
m_tStatusBar.Handle = lngPrgrssBarHandle
End If
End Sub
Public Sub ProgressTick(Optional Text As String = vbNullString)
Const lngMax_c As Long = 100
Const lngIncrement_c As Long = 1
If m_tStatusBar.Progress >= lngMax_c Then
ProgressUpdate m_lngNoValue_c, Text
Else
ProgressUpdate (m_tStatusBar.Progress + lngIncrement_c) / lngMax_c, Text
End If
End Sub
Public Sub ProgressUpdate(ByVal Progress As Single, Optional ByVal Text As String = vbNullString)
Const sngZero_c As Single = 0#
Const sngOne_c As Single = 1#
Const sngMax_c As Long = 100#
Const lngUpdate_c As Long = 1026
Const strFormat_c As String = """Working: ""0.00""% Complete..."""
Const bytNBSP_c As Long = 160
Dim lngTmpPrg As Long
If m_tStatusBar.Handle = m_lngNoValue_c Then
CreateProgressBar
End If
If Progress < sngZero_c Then
Progress = VBA.Abs(Progress)
End If
If Progress > sngOne_c Then
Progress = Progress - (Progress \ sngOne_c)
End If
Progress = sngMax_c * Progress
lngTmpPrg = CLng(Progress)
If lngTmpPrg <> m_tStatusBar.Progress Then
m_tStatusBar.Progress = lngTmpPrg
SendMessage m_tStatusBar.Handle, lngUpdate_c, m_tStatusBar.Progress, m_lngNoValue_c
End If
If Text = VBA.ChrW$(bytNBSP_c) Then
Text = VBA.Format$(Progress, strFormat_c)
End If
If m_tStatusBar.CurrentText <> Text Then
m_tStatusBar.CurrentText = Text
objApp.StatusBar = Text
End If
End Sub
Public Sub ProgressBarHide()
DestroyWindow m_tStatusBar.Handle
m_tStatusBar.Handle = m_lngNoValue_c
End Sub
Public Sub ProgressBarShow()
If m_tStatusBar.Handle = m_lngNoValue_c Then
CreateProgressBar
End If
ProgressUpdate m_tStatusBar.CurrentText, m_tStatusBar.Progress
End Sub
Public Property Get StatusBarText() As Variant
StatusBarText = objApp.StatusBar
End Property
Public Property Let StatusBarText(ByVal NewValue As Variant)
Const strFalse_c As String = "False"
Const lngMatch_c As Long = 0
If VBA.StrComp(NewValue, strFalse_c, vbTextCompare) = lngMatch_c Then
NewValue = False
End If
objApp.StatusBar = NewValue
End Property
Public Sub FormattedError(e As VBA.ErrObject)
Const strTitle_c As String = "Exception Encountered"
Const lngButtons_c As Long = VBA.VbMsgBoxStyle.vbCritical + _
VBA.VbMsgBoxStyle.vbMsgBoxSetForeground + _
VBA.VbMsgBoxStyle.vbSystemModal
Dim strMsg As String
If e.Number <> m_lngNoValue_c Then
strMsg = "And exception number " & e.Number & " occurred in " & e.Source & ":" & _
vbNewLine & e.Description
If e.HelpFile = vbNullString Then
VBA.MsgBox strMsg, lngButtons_c, strTitle_c
Else
VBA.MsgBox strMsg, lngButtons_c + vbMsgBoxHelpButton, strTitle_c, _
e.HelpFile, e.HelpContext
End If
End If
End Sub
|