Monday, January 14, 2019

VBA Add an animated Notification Box to your Excel Program

For those of us who create programs and add-ins in Excel, we are very, very familiar with the message box.  The message box gives us the opportunity to give the user a message. That message could be notice of an error, notification of a complete macro, or some other message.

The problem, however, is that this message box is modal. This means that it takes focus, and you cannot interact with Excel until you click the "OK" button (or whatever other buttons you use).  On top of this, it also stops the VBA code. This means that your VBA code will not continue until the user clicks the "OK" button.  This can be good in some instances where you need the user to understand something before it continues. However, sometimes you just want a little notification box to pop up and the VBA code to continue.  The user can then read the box at their leisure and dismiss it as soon as they wish.

I have created a nice little pop up box which does just this.  It is based on the concept in various web programs (It was once present in Facebook, gmail desktop notifier, and others). Basically, it is a little box which pops up in the bottom right corner with a little message.

For my version of the popup box, it even includes features such as the ability to show many pop-up boxes on top of each other, and when one in the middle is dismissed, the top boxes move down.

See the Examples below:

One box:


Multiple boxes:





The idea is very interesting.  I will admit, it's not just a simple thing to make (but it's also not that complicated either), so I will provide an add-in file that you are welcome to use in your projects (both commerical and personal).  For those who want to know more, I will outline the steps below and show you the code.

To use the add-in:

Download the file here
Make sure to right-click, click properties, click "Unlock" to enable use of the addin.  You can add the file to your addin directory, or you can double click it to use it on demand.

use the code below to show a new popup box. You run it any number of times, but if you show too many popups, they may start to go off screen.

 showPopUpBox "My Message Here"  

That's it!


---
Now, for the technical side of things!


Steps:
1. Build a userform with a label. (I also add a picture of an envelope to make it look nicer)
2. Play around with the settings to make the userform look how you want it
3. Make sure the userform's property showModal is equal to false
4. Add code in the userform_activate to hide the title bar, add transparency, and add a little animation
5. Create a function to close the userform with animation and move any other messages down if needed
6. Add a function to move a message down
7. Add global variables to define the userform's index and text to display
8. Create a function to call in order to show the popup box (in a module)
9. Create a function to determine which popup boxes to move down (in a module)
10. Create a function which actually displays the popup box (in a module)


Phew! Okay, that concludes the steplist. Here is the code associated:

for step 4:

 'Windows API calls to handle windows (used to remove x button in top right corner)  
 #If VBA7 Then  
   Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  
   Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long  
   Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
   Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long  
   Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long  
 #Else  
   Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  
   Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
   Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long  
   Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long  
   Private Declare Function SetLayeredWindowAttributes Lib "user32"(ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long  
 #End If  
   
 Private Const mcGWL_STYLE = (-16)  
 Private Const mcWS_SYSMENU = &H80000  
   
 Dim cIndex As Long  
 Public strText As String  
   
 Sub HideTitleBar(frm As Object)  
   
   'hides the title bar using the windows API  
   'also makes form semi-transparent (bytOpacity)  
     
   Const GWL_STYLE = -16  
   Const WS_CAPTION = &HC00000  
   Const GWL_EXSTYLE = (-20)  
   Const WS_EX_LAYERED = &H80000  
   Const LWA_ALPHA = &H2&  
   Dim bytOpacity As Byte  
   
   Dim lngWindow As Long  
   Dim lFrmHdl As Long  
     
   'set the variables  
   'get the correct window  
   bytOpacity = 192  
   lFrmHdl = FindWindow(vbNullString, frm.Caption)  
   lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)  
   lngWindow = (lngWindow And (Not WS_CAPTION))  
     
   'call the windows API functions  
   'remove title bar  
   Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)  
   'make transparent  
   Call SetWindowLong(lFrmHdl, GWL_EXSTYLE, lngWindow Or WS_EX_LAYERED)  
   'redraw  
   Call DrawMenuBar(lFrmHdl)  
   Call SetLayeredWindowAttributes(lFrmHdl, 0, bytOpacity, LWA_ALPHA)  
 End Sub  
   
 Private Sub UserForm_Activate()  
   Static isRun As Boolean  
     
   If isRun Then Exit Sub  
     
   Dim scBottom, scRight  
     
   'get application dimensions  
   scBottom = Application.Top + Application.Height - (FormCount * Me.Height)  
   scRight = Application.Left + Application.width  
   'set location  
   Me.Top = scBottom + Me.Height  
   Me.Left = scRight - Me.width  
     
   Me.Label1.Caption = strText  
     
   HideTitleBar Me  
     
   popUP  
   isRun = True  
 End Sub  
   
 Private Sub popUP()  
   On Error GoTo errHandler  
     
   Dim scBottom, quality As Long, origHeight  
   Dim myTimer  
     
   scBottom = Application.Top + Application.Height - (FormCount * Me.Height)  
     
   'animation quality  
   quality = 20  
   'original height  
   origHeight = Me.Height  
     
   'start popup  
   Me.Height = 1  
   
   For i = 1 To quality  
     DoEvents  
     Me.Height = (i / quality) * origHeight  
     Me.Top = scBottom - Me.Height  
     'wait a little  
     myTimer = timer  
     Do  
       DoEvents  
     Loop Until timer - myTimer > 0.02  
   Next i  
 Exit Sub  
 errHandler:  
   Debug.Print Err.Description  
   Resume Next  
 End Sub  


Okay, so there are a few API calls here. Those are used to specifically hide the title bar and make the form somewhat transparent.  There are a few things you can modify there if you want to customize it, but I don't recommend it.

If you don't understand this code, it is best to simple copy and paste it, but if you want to learn more look up windows API calls from VBA on google or msdn and "Make Userforms transparent in Excel VBA" on stackoverflow or Google.  These will help you get started.

Now, for step 5 6 and 7


 Private Sub Image1_Click()  
   popDOWN  
 End Sub  
   
 Private Sub Label1_Click()  
   popDOWN  
 End Sub  
   
 Private Sub Label2_Click()  
   popDOWN  
 End Sub  
   
 Private Sub popDOWN()  
   Dim scBottom, scRight, quality As Long, origHeight  
   Dim myTimer  
     
   'get application dimensions  
   scBottom = Me.Top + Me.Height  
   scRight = Application.Left + Application.width  
   'animation quality  
   quality = 20  
   'original height  
   origHeight = Me.Height  
     
   'close popup  
   For i = quality To 1 Step -1  
     DoEvents  
     Me.Height = (i / quality) * origHeight  
     Me.Top = scBottom - Me.Height  
     'wait a little  
     myTimer = timer  
     Do  
       DoEvents  
     Loop Until timer - myTimer > 0.01  
   Next i  
     
   Unload Me  
   Call moveAllPopups(cIndex)  
 End Sub  
   
 Private Sub UserForm_Click()  
   popDOWN  
 End Sub  
   
 Function FormCount() As Long  
  Dim UForm As Object  
  Dim iCount As Long  
   
  For Each UForm In VBA.UserForms  
   If UForm.Name = Me.Name Then  
    iCount = iCount + 1  
   End If  
  Next  
    
  FormCount = iCount - 1  
  cIndex = iCount - 1  
 End Function  
   
 Public Function moveDown(indexGone As Long)  
   Dim myTimer, startTop  
     
   If indexGone >= cIndex Then Exit Function  
     
   startTop = Me.Top  
   cIndex = cIndex - 1  
     
   For i = 1 To 20  
     Me.Top = startTop + ((i / 20) * Me.Height)  
     DoEvents  
     myTimer = timer  
     Do  
       DoEvents  
     Loop Until timer - myTimer > 0.01  
   Next i  
 End Function  


Most of this code are event handlers for when you click on the userform.  They call the procedure "popDOWN" which animates the descension of and unloads the form.  There is another function called "moveDown" which moves the userform down the amount equal to its height. This helps when a user dismisses a message below other messages. The messages above will eventually move down.

Last, is the code in a new module. This code will handle the creating and moving of the userform.  It is important to note that if the user moves or resizes the window, the userforms will remain where they are and you might have some strange results if they start dismissing some of the messages.  Perhaps there is an event handler for moving the window that we can leverage. I know there is a handler for resizing a window, but for the purpose of this demonstration, I have not used it.

 Public Sub showPopUpBox(sMessage As String)  
   'displays a temporary message  
   'extended time for longer messages  
     
   Dim vNotAllowed As Variant  
     
   vNotAllowed = Array("'")  
     
   'Add escape characters  
   For Each v In vNotAllowed  
     sMessage = Replace(sMessage, v, v & v)  
   Next  
   'also remove any line breaks  
   sMessage = Replace(sMessage, vbCrLf, " ")  
     
   'show the popup  
   Application.OnTime Now(), "'startPopup """ & sMessage & """'"  
 End Sub  
 Public Sub startPopup(sText As String)  
   'This must only be called with application.ontime  
   'to avoid stopping future VBA code  
   On Error GoTo errHandler  
     
   Dim myPopup As popupBox  
     
   Set myPopup = New popupBox  
   myPopup.strText = sText  
   myPopup.Show  
     
 Exit Sub  
 errHandler:  
   Debug.Print Err.Description  
   Resume Next  
 End Sub  
 Public Sub moveAllPopups(cIndex As Long)  
   'On Error Resume Next  
   Dim UForm As Object  
     
   For Each UForm In VBA.UserForms  
     If LCase(UForm.Name) = "popupbox" Then  
       UForm.moveDown cIndex  
     End If  
   Next  
 End Sub  


There are two key things here.

 1. We don't want to open the popup box directly. Instead, we call a function with application.ontime.  This allows us to run other VBA code while the popup box is displayed. It is *almost* asynchronous, but not quite.
 2. We have a subroutine which checks each of the popup boxes and runs the "moveDown" function.  It passes along with it the index of the form that was being dismissed which helps determine if the popup box needs to be moved down or not.

That's about it.  After this has all been put together, you can create a new message popup box by calling


 showPopUpBox "My Message Here"  


Go ahead! Try it out!

VBA Add an animated Notification Box to your Excel Program

For those of us who create programs and add-ins in Excel, we are very, very familiar with the message box.  The message box gives us the opp...