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!
No comments:
Post a Comment