Excel

Self-Restoring Application Interface Lock

Ease of Use

Hard

Version tested with

2003 

Submitted by:

Oorang

Description:

The primary goal of this Class to provide one easy to is a Self-Restoring Application Interface Lock. 

Discussion:

As you begin to produce more polished Excel-VBA, it is not unusual to find yourself starting your code the same way over and over... Turn off events; Turn off Screen-Updating; Turn ON the hourglass; Transfer control of the interrupt key;Create an error handler, so on and so forth. The problem occurs when you forget to turn all those things back ON. This can be handled quite nicely by localizing all tasks to a single class module. Placing these actions in a Class Module allows you take advantage of the Class_Terminate event to restore the Interface. In this way whenever a the calling Procedure terminates the Interface is automatically restored. You can also use this Class to Control the StatusBar and a Progress Bar. Please be aware that anytime you use a progress meter, there is a corresponding performance hit. Note: Progressbar method is an adaptation of a method originally expounded by Ivan F. Moala. 

Code:

instructions for use

			

''========================================================================================== ''Module Name : XLInterface Class ''Author : Aaron Bush 2006 (Free for Public Use) ''Purpose : To provide a centralized control point for the most commonly used '' Excel interface points that automatically restores changes when '' Class falls out of scope. ''Method : Use interface's restrict method to Lock down Excel while code is '' running. When the class falls out of scope (calling procedure ends) '' Class_Terminate event is called. Change OnClose property to determine '' if Application is set back to it's original settings, or simply set to '' it's least restricted settings. ''Changes : Name Date Description '' Aaron Bush 2007-09-17 Insourced progress bar using '' Ivan F. Moala's API method. '' http://www.xcelfiles.com/ProgressBarXP.html ''========================================================================================== Option Explicit Option Compare Binary Option Base 0 Public Enum abOnCloseBehavior abNoAction = 0 abRestore = 1 abUnrestrict = 2 abRestrict = 4 End Enum 'Holds information about the StatusBar/Progress bar combination: Private Type StatusBar Handle As Long OriginalValue As Variant VisibilityOriginal As Boolean CurrentText As Variant Progress As Long End Type 'API functions used for creation of a ProgressBar control on the Application Status Bar. 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 'Progress bar only updates if the new value is different from the old 'value. Set to negative value so if legal value "0" is given it will 'be used. m_tStatusBar.Progress = -1 m_eOnClose = abRestore End Sub Private Sub Class_Terminate() On Error Resume Next Const m_lngNoValue_c As Long = 0 'Use OnClose property to determine how to restore interface. 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 'Else Do nothing End If 'In all scenarios, destroy ProgressBar if created. If m_tStatusBar.Handle <> m_lngNoValue_c Then Me.ProgressBarHide End If End Sub Public Sub Unrestrict() 'Purpose: Set Excel.Application to it's least restricted state. objApp.EnableEvents = True objApp.DisplayAlerts = True objApp.Cursor = xlDefault objApp.StatusBar = False objApp.ScreenUpdating = True objApp.EnableCancelKey = xlInterrupt End Sub Public Sub Restore() 'Purpose: Set Excel.Application to it's last recorded state. 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 'Force Boolean false for proper processing. 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() 'Purpose: Set Excel.Application to it's most restricted state. 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() 'Purpose: Record current settings of Excel.Application. '(Auto-Triggered on Class Instanstiation.) 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 'Force Boolean false for proper processing. 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 ''==================================== ''Determine behavior of OnClose Event. 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) 'Try to obtain an already existing bar if possible: lngPrgrssBarHandle = FindWindowEx(lngStatusBarHandle, lngNoChild_c, strClsNameLED_c, vbNullString) If lngPrgrssBarHandle = lngNoMatch_c Then 'If not already existing bar, create one. 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) 'Increments the progress bar by 1. Wraps to 0 when 100 is reached. 'If text argument is Special Character 160, the Statusbar will 'also display a generic pre-formatted progress message. 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) 'Purpose: Sets the progress bar value to whatever value passed. 'Inputs : -Progess: A value representing the percent complete. ' If passed a negative number, the absolute value ' will be used. If passed a number greater than ' one, only the decimal portion will be used. ' -Text : The value you wished displayed in the StatusBar. ' If text argument is Special Character 160, the ' Statusbar will display a generic pre-formatted ' progress message. 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 progress bar isn't created, create it. If m_tStatusBar.Handle = m_lngNoValue_c Then CreateProgressBar End If 'If number is negative, use Absolute Value (Ex: -.45 = .45) If Progress < sngZero_c Then Progress = VBA.Abs(Progress) End If 'If number is greater than one use only decimal portion. 'Ex: 1.25 = .25 If Progress > sngOne_c Then Progress = Progress - (Progress \ sngOne_c) End If 'Convert decimal to long. Progress = sngMax_c * Progress lngTmpPrg = CLng(Progress) 'Only try to update the progress bar if it's value is changed. '(Reduces flicker.) If lngTmpPrg <> m_tStatusBar.Progress Then m_tStatusBar.Progress = lngTmpPrg SendMessage m_tStatusBar.Handle, lngUpdate_c, m_tStatusBar.Progress, m_lngNoValue_c End If 'Check for message creation flag. If Text = VBA.ChrW$(bytNBSP_c) Then Text = VBA.Format$(Progress, strFormat_c) End If 'Only try to update the status bar if it's value is changed. '(Reduces flicker.) If m_tStatusBar.CurrentText <> Text Then m_tStatusBar.CurrentText = Text objApp.StatusBar = Text End If End Sub Public Sub ProgressBarHide() 'Removes the Progressbar from the Statusbar. Values are retained. DestroyWindow m_tStatusBar.Handle m_tStatusBar.Handle = m_lngNoValue_c End Sub Public Sub ProgressBarShow() 'Restores Progressbar to the Statusbar. Last Values are shown. 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 'Sends text the Excel.Application.StatusBar StatusBarText = objApp.StatusBar End Property Public Property Let StatusBarText(ByVal NewValue As Variant) 'Retrieves text from the Excel.Application.StatusBar Const strFalse_c As String = "False" Const lngMatch_c As Long = 0 'Force Boolean false for proper processing. 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) 'Displays preformatted error message. 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

How to use:

  1. Press Alt-F11 to launch the Visual Basic Editor.
  2. Press ctrl-m to import file.
  3. Import file names XLInterface.cls in attached files. (This method will preserve the descriptions for the object browser.
  4. In a new procedure Declare an object of the type XLInterface.
  5. Use the "Restrict" method to turn off the interface.
 

Test the code:

  1. See attached xls file for possible implementations.
 

Sample File:

InterfaceExample.zip 39.23KB 

Approved by mdmackillop


This entry has been viewed 267 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express