Show system tray balloon tooltip in VBA

[barev]

Hello,

I am trying to use the following proof-of-concept code to show a balloon tooltip from a VBA form, which has been sent to the system tray with a generic excel icon. The code is executed in Excel 2007 on a Windows XP SP3 machine. I have one userform with two command buttons and one module in the project. The code is as follows:

'***************** START USERFORM1 CODE ******************
Private Sub CommandButton1_Click()
Dim Me_hWnd As Long, Me_Icon As Long, Me_Icon_Handle As Long, IconPath As String _
Me_hWnd = FindWindowd("ThunderDFrame", Me.Caption)
IconPath = Application.Path & Application.PathSeparator & "excel.exe" _
Me_Icon_Handle = ExtractIcond(0, IconPath, 0)
Hook Me_hWnd
AddIconToTray Me_hWnd, 0, Me_Icon_Handle, "Double Click to re-open userform"
BalloonPopUp
Me.Hide
End Sub

Private Sub CommandButton2_Click()
Application.Visible = True
Unload Me
End Sub

Private Sub UserForm_Activate()
RemoveIconFromTray
Unhook
End Sub

Private Sub UserForm_Initialize()
Application.Visible = False
End Sub
'****************** END USERFORM1 CODE *******************



'***************** START MODULE CODE ******************
Option Explicit
Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal _
As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long

Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBL = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBL = &H206
Public Const WM_ACTIVATEAPP = &H1C

Public Const NIS_HIDDEN = &H1
Public Const NIS_SHAREDICON = &H2
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIF_STATE = &H8
Public Const NIF_INFO = &H10
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const MAX_TOOLTIP As Integer = 64
Public Const GWL_WNDPROC = (-4)

'shell version / NOTIFIYICONDATA struct size constants
Public Const NOTIFYICONDATA_V1_SIZE As Long = 88 'pre-5.0 structure size
Public Const NOTIFYICONDATA_V2_SIZE As Long = 488 'pre-6.0 structure size
Public Const NOTIFYICONDATA_V3_SIZE As Long = 504 '6.0+ structure size
Public NOTIFYICONDATA_SIZE As Long


Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * MAX_TOOLTIP
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End Type

Public nfIconData As NOTIFYICONDATA

' list the icon types for the balloon message..
Public Const vbNone = 0
Public Const vbInformation = 1
Public Const vbExclamation = 2
Public Const vbCritical = 3

Private FHandle As Long
Private WndProc As Long
Private Hooking As Boolean

Public Sub Hook(Lwnd As Long)
If Hooking = False Then
FHandle = Lwnd
WndProc = SetWindowLong(Lwnd, GWL_WNDPROC, AddressOf WindowProc)
Hooking = True
End If
End Sub

Public Sub Unhook()
If Hooking = True Then
SetWindowLong FHandle, GWL_WNDPROC, WndProc
Hooking = False
End If
End Sub

Public Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Hooking Then
If lParam = WM_LBUTTONDBL Then
UserForm1.Show 1
WindowProc = True
' Unhook
Exit Function
End If
WindowProc = CallWindowProc(WndProc, hw, uMsg, wParam, lParam)
End If
End Function

Public Sub RemoveIconFromTray()
Shell_NotifyIcon NIM_DELETE, nfIconData
End Sub

Public Sub AddIconToTray(MeHwnd As Long, MeIcon As Long, MeIconHandle As Long, Tip As String)
With nfIconData
.hWnd = MeHwnd
.uID = MeIcon
.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
.uCallbackMessage = WM_RBUTTONUP
.dwState = NIS_SHAREDICON
.hIcon = MeIconHandle
.szTip = Tip & Chr$(0)
.cbSize = NOTIFYICONDATA_V3_SIZE
End With
Shell_NotifyIcon NIM_ADD, nfIconData
End Sub

Public Sub BalloonPopUp()
' ok, create a balloon popup..
With nfIconData
.dwInfoFlags = vbInformation
.uFlags = NIF_INFO
.szInfoTitle = "ToolTip" & vbNullChar
.szInfo = "Message" & vbNullChar
End With

' ok, write it to the system tray icon
Shell_NotifyIcon NIM_MODIFY, nfIconData

End Sub

Function FindWindowd(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
FindWindowd = FindWindow(lpClassName, lpWindowName)
End Function

Function ExtractIcond(ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
ExtractIcond = ExtractIcon(hInst, lpszExeFileName, nIconIndex)
End Function

Sub ShowUserForm()
Application.Visible = False
UserForm1.Show 1
End Sub
'****************** END MODULE CODE *******************

When running the form if commandbutton1 is clicked, the excel sheet and form are hidden, a generic excel icon is shown in the system tray with a balloon tooltip.
The problem is the code sort of works and a balloon tooltip is shown from the tray icon, however the title, text and icon in the tooltip are not shown. I basically get the following output 4696 (check the attached screenshot).

Does anyone know the reason for this and how to achieve the expected result? Thanks for the help in advance!

[Kenneth Hobs]

Try using Trim() to trim your tooltip string.

It helps us to troubleshoot your code if you will attach the workbook or use Option Explicit at the top of your Userform and Module to insure that variables and defined. When posting snippets of code, it is easy to leave out parts.

[barev]

Hi Kenneth, thank you for your reply.

I tried your suggestions but I still get the same result.

I have attached my sheet. 4707

[barev]

I got some help over at the mrexcel forums and found the culprit in the code:


... not allocating enough space in the szTip String buffer.

Change : Public Const MAX_TOOLTIP As Integer = 64 to 128

[Kenneth Hobs]

Thanks sharing your solution. I thought that I had tried something like that. It is neat to know how to do it in vba. In vb.net, it was easy.