0 votes
in VBA by Beginner (5 points)

Regarding the system tray notification macro, I cannot find the comments section where you wrote I could find code samples compatible with Windows 10. Please direct me to the right place. I must have overlooked it. Thanks, Bruce

1 Answer

0 votes
by Super Expert (3.2k points)
selected by
 
Best answer

Sorry about that, Bruce! I disabled comments on the site about 9 months ago to speed up the page speeds. Fortunately, the code in the system tray notification macro you linked to is fully compatible with Windows 10, though. The old comments on that tutorial supported versions of Windows released before Windows 7. 

I looked through the comments and this is the code someone had adapted to work with Access using classes instead of a UserForm. He tested it on Windows 10 and it looks like it worked on older systems, as well. 

I tested this on a 32-bit version of Excel 2010 and it works fine there, as well. The only difference I encountered was the icon does not appear in the start menu system tray and the blank square that's created instead isn't removed once balloon tooltip is closed. Even so, the class module is a great alternative way of displaying the balloon in your notification tray than the one in the original tutorial you linked to!

Anyway, here's the code and comment from my old comment archives:

Douglas Lima

Hello Ryan and everybody,

I found out a code in a forum for MS Access. I adapted this code to work with Excel... don't need to have the userform created... It's working for me perfectly in a windows 10 64bits - Excel 2016... hope someone can find it useful as well...

---------Create a module: modBaloonTooltip---------

'Author: murray83 (Daventry, UK)
'Source: https://www.access-programm...
'Adapted from MS Access to Excel by: Douglas Lima
'Requires the class BalloonTooltip

Option Explicit
Dim bt As BalloonTooltip

Public Enum btIcon
btNone
btInformation
btWarning
btCritical
End Enum

Public Sub ShowBalloonTooltip(strHeading As String, strMessage As String, lngIcon As btIcon)
'Wrapper function to call the class so it can be called from an add-in code library
Set bt = New BalloonTooltip
With bt
.Heading = strHeading
.Message = strMessage
.Icon = lngIcon
.Show
End With
End Sub

Public Sub Hide Icon()
If Not bt Is Nothing Then
With bt
.Hide
End With
End If
End Sub

______________________________________________

---------Create a Class: BalloonTooltip---------

'Author: murray83 (Daventry, UK)
'Source: https://www.access-programm...
'Adapted from MS Acc ess to Excel by: Douglas Lima
'Usage can be found in modBalloonTooltip

Option Explicit

Private mlngIcon As Long
Private mstrHeading As String
Private mstrMessage As String

Private Const APP_SYSTRAY_ID = 999

Private Const NOTIFYICON_VERSION = &H3

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NIM_VERSION = &H5

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

Private Const NIIF_NONE = &H0
Private Const NIIF_INFO = &H1
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_GUID = &H5
Private Const NIIF_ICON_MASK = &HF
Private Const NIIF_NOSOUND = &H10

Private Cons t WM_USER = &H400
Private Const NIN_BALLOONSHOW = (WM_USER + 2)
Private Const NIN_BALLOONHIDE = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5)

Private Const NOTIFYICONDATA_V1_SIZE As Long = 88
Private Const NOTIFYICONDATA_V2_SIZE As Long = 488
Private Const NOTIFYICONDATA_V3_SIZE As Long = 504
Private NOTIFYICONDATA_SIZE As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 128
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeoutAndVersion As Long
szInfoTitle As String * 64
dwInfoFlags As Long
guidItem As GUID
End Type

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) As Long

Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, _
lpdwHandle As Long) As Long

Private Declare Function GetFileVersionInfo Lib "version.dll" _
Alias "GetFileVersionInfoA" _
(ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
lpData As Any) As Long

Private Declare Function VerQueryValue Lib "version.dll" _
Alias "VerQueryValueA" _
(pBlock As Any, _
ByVal lpSubBlock As String, _
lpBuffer As Any, _
nVerSize As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)

Private Const WM_GETICON = &H7F

Private Const WM_SETICON = &H80
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_LOADFROMFILE = &H10

Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

Private Declare Function apiLoadImage Lib "user32" _
Alias "LoadImageA" _
(ByVal hInst As Long, _
ByVal lpszName As String, _
ByVal uT ype As Long, _
ByVal cxDesired As Long, _
ByVal cyDesired As Long, _
ByVal fuLoad As Long) _
As Long

Private Declare Function apiSendMessageLong Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long

Private Const SHGFI_ICON = &H100
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_TYPENAME = &H400
Private Const SHGFI_ATTRIBUTES = &H800
Private Const SHGFI_ ICONLOCATION = &H1000

Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260

Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _
Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbSizeFileInfo As Long, _
ByVal uFlags As Long) _
As Long

Private Declare Function apiDestroyIcon Lib "user32" _
Alias "DestroyIcon" _
(ByVal hIcon As Long) _
As Long

Private psfi As SHFILEINFO

Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3

Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" _
(ByVal hWnd As Long, _
ByVal nCmdShow As Long) _
As Long

Private Sub ShellTrayAdd()

Dim nID As NOTIFYICONDATA

If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion

With nID

.cbSize = NOTIFYICONDATA_SIZE
.hWnd = Application.hWnd

.uID = APP_SYSTRAY_ID
.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
.dwState = NIS_SHAREDICON
.hIcon = fSetIcon(GetAppIcon)

.szTip = "DHLGM Message Service" & vbNullChar
.uTimeoutAndVersion = NOTIFYICON_VERSION

End With

Call Shell_NotifyIcon(NIM_A DD, nID)

Call Shell_NotifyIcon(NIM_SETVERSION, nID)

End Sub

Private Sub ShellTrayRemove()

Dim nID As NOTIFYICONDATA

If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion

With nID
.cbSize = NOTIFYICONDATA_SIZE
.hWnd = Application.hWnd
.uID = APP_SYSTRAY_ID
End With

Call Shell_NotifyIcon(NIM_DELETE, nID)
Call apiDestroyIcon(nID.hIcon)
End Sub

Private Sub ShellTrayModifyTip(nIconIndex As Long)

Dim nID As NOTIFYICONDATA

If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion

With nID
.cbSize = NOTIFYICONDATA_SIZE
.hWnd = Application.hWnd
.uID = APP_SYSTRAY_ID
.uFlags = NIF_INFO
.dwInfoFlags = nIconIndex

.szInfoTitle = mstrHeading & vbNullChar
.szInfo = mstrMessage & vbNullChar
End With

Call Shell_NotifyIcon(NIM_MODIFY, nID)

End Sub

Private Sub SetShellVersion()

Select Case True
Case IsShellVersion(6)
NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE

Case IsShellVersion(5)
NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE

Cas e Else
NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
End Select

End Sub

Private Function IsShellVersion(ByVal version As Long) As Boolean

Dim nBufferSize As Long
Dim nUnused As Long
Dim lpBuffer As Long
Dim nVerMajor As Integer
Dim bBuffer() As Byte

Const sDLLFile As String = "shell32.dll"

nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)

If nBufferSize > 0 Then

ReDim bBuffer(nBufferSize - 1) As Byte

Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))

If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then

CopyMemory nVerMajor, ByVal lpBuffer + 10, 2

IsShellVersion = nVerMajor >= version

End If

End If

End Function

Private Funct ion GetSelectedOptionIndex() As Long

GetSelectedOptionIndex = 2

End Function

Public Property Get Icon() As btIcon
Icon = mlngIcon
End Property

Public Property Let Icon(ByVal lngIcon As btIcon)
mlngIcon = lngIcon
End Property

Public Property Get Heading() As String
Heading = mstrHeading
End Property

Public Property Let Heading(ByVal strHeading As String)
mstrHeading = strHeading
End Property

Public Property Get Message() As String
Message = mstrMessage
End Property

Public Property Let Message(ByVal strMessage As String)
mstrMessage = strMessage
End Property

Public Sub Show()
Call ShellTrayAdd
ShellTrayModifyTip mlngIcon
End Sub

Public Sub Hide()
ShellTrayRemove
End Sub

Private Function fSetIcon(strIconPath As String) As Long
Dim hIcon As Long
hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
If hIcon Then
fSetIcon = hIcon
End If
End Function

Public Function GetAppIcon() As String
' Dim dbs As DAO.Database, prp As Property
' Const conPropNotFoundError = 3270
' On Error GoTo GetAppIcon_Error
'
' Beep
' Set dbs = CurrentDb
' GetAppIcon = dbs.Properties("AppIcon")

ExitHere:
Exit Function

GetAppIcon_Error:

Select Case Err.Number
Case 3270 'PropertyC Not Found
'db doesn't have an associated icon - no message needed
' MsgBox "Current Database needs to have a custom icon", vbCritical, "No Icon Found"
Resume ExitHere
Case Else
MsgBox "An Unexpected Error has occured please inform IT Support Error " & Err.Numbe r & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2"
Resume ExitHere
End Select
'Debug Only
Resume

End Function

 

Welcome to wellsr Q&A
wellsr Q&A is the VBA and Python programming community that rewards you for learning how to code.

Getting Started
Register
VBA Cheat Sheets (On Sale Now)

Earn free prizes for asking VBA and Python questions and for answering questions asked by others in our community.

Looking for something else? Hire our professional VBA Help, instead.

What makes us different?
Our points system rewards you with a chance for free gifts based on the quality of your questions and answers. All you have to do is post and you could get rewarded, like these members:

ParserMonster $25 Amazon Gift Card
Hightree $10 Amazon Gift Card
Thales1 $10 Amazon Gift Card
runfunke $10 Amazon Gift Card
coolag $10 Amazon Gift Card
Siew Hun $10 Amazon Gift Card

So, why don't you join us? It really is an encouraging way to motivate members in our VBA and Python community.

Register

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.

...