System tray tooltip balloon

[Slade2000]

Hi All

I know this is not 100% the correct place to ash a full on VB6 question but this forum is always most helpful.

I got code that can display a message in the systemtray as a balloon (Same as when windows gives you a message). This code works 100% in XP but does not work in Win7

Can someone please assist. I will post all my modules here.

Form Code

Private Sub cmdBalloon_Click(Index As Integer)

    TrayBalloon pbTray, txtTitle.Text, txtMsg.Text, Index

End Sub

Private Sub Form_Load()
Dim tmp
    
    tmp = RegRead(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\", "EnableBalloonTips")
    MsgBox tmp
    If tmp = 0 Then
        If MsgBox("Balloon tips are currently disabled on your computer. Would you like to enable them?", vbQuestion + vbYesNo, "Enable Balloon Tips?") = vbYes Then
            WriteDWORD HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\", "EnableBalloonTips", 1
            If MsgBox("Balloon tips are now enabled, but you must first logoff your computer" & vbNewLine & "and then log back on before the changes will take effect." & vbNewLine & vbNewLine & "Would you like to be logged off now?", vbQuestion + vbYesNo, "Logoff Now?") = vbYes Then
                LogOffNT True
                End
            End If
        Else
            MsgBox "Without balloon tips enabled on your computer, this program will not function properly.", vbExclamation, "Balloon Tips Disabled"
        End If
    End If
                
    TrayAdd pbTray
   
End Sub

Private Sub Form_Unload(Cancel As Integer)

   TrayRemove pbTray
   
End Sub

Module1 Code

Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32.dll" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long

Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_QUERY = &H8
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const ANYSIZE_ARRAY = 1
Private Const VER_PLATFORM_WIN32_NT = 2

Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Public Type LUID
    LowPart As Long
    HighPart As Long
End Type

Public Type LUID_AND_ATTRIBUTES
    pLuid As LUID
    Attributes As Long
End Type

Public Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type


Public Function IsWinNT() As Boolean
Dim myOS As OSVERSIONINFO

    myOS.dwOSVersionInfoSize = Len(myOS)
    GetVersionEx myOS
    IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT)
    
End Function

Private Sub EnableShutDown()
    Dim hProc As Long
    Dim hToken As Long
    Dim mLUID As LUID
    Dim mPriv As TOKEN_PRIVILEGES
    Dim mNewPriv As TOKEN_PRIVILEGES

    hProc = GetCurrentProcess()
    OpenProcessToken hProc, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, hToken
    LookupPrivilegeValue "", "SeShutdownPrivilege", mLUID
    mPriv.PrivilegeCount = 1
    mPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
    mPriv.Privileges(0).pLuid = mLUID
    
    AdjustTokenPrivileges hToken, False, mPriv, 4 + (12 * mPriv.PrivilegeCount), mNewPriv, 4 + (12 * mNewPriv.PrivilegeCount)
End Sub

Public Sub RebootNT(Force As Boolean)
Dim r As Long, Flags As Long

    Flags = EWX_REBOOT
    If Force Then Flags = Flags + EWX_FORCE
    If IsWinNT Then EnableShutDown
    ExitWindowsEx Flags, 0
End Sub

Public Sub LogOffNT(Force As Boolean)
Dim r As Long, Flags As Long

    Flags = EWX_LOGOFF
    If Force Then Flags = Flags + EWX_FORCE
    ExitWindowsEx Flags, 0
End Sub

Module2 code

Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal KeyRoot As kRoot, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Public Enum regType
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
End Enum

Const REG_OPTION_NON_VOLATILE = 0

Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
                     
Public Enum kRoot
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum

Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Boolean
End Type

Public Function WriteDWORD(ByVal KeyRoot As kRoot, ByVal KeyName As String, ByVal SubKeyName As String, ByVal SubKeyValue As Long) As Boolean
Dim r As Long, hkey As Long
    
    r = RegCreateKey(KeyRoot, KeyName, hkey)
    
    If (r <> ERROR_SUCCESS) Then GoTo Err_Hnd
    
    r = RegSetValueEx(hkey, SubKeyName, 0, REG_DWORD, SubKeyValue, 4)
                       
    If (r <> ERROR_SUCCESS) Then GoTo Err_Hnd

    RegCloseKey hkey
    
    WriteDWORD = True

Exit Function
Err_Hnd:
    
    WriteDWORD = False
    RegCloseKey hkey
    
End Function

Public Function RegRead(KeyRoot As kRoot, KeyName As String, SubKeyName As String) As String
Dim i As Long, r As Long, hkey As Long, hDepth As Long, lKeyValType As Long, KeyValSize As Long
Dim sKeyVal As String, tmpVal As String
    
    r = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hkey)
    
    If (r <> ERROR_SUCCESS) Then GoTo Err_Hnd
    
    tmpVal = String$(1024, 0)
    KeyValSize = 1024
    
    r = RegQueryValueEx(hkey, SubKeyName, 0, lKeyValType, tmpVal, KeyValSize)
                        
    If (r <> ERROR_SUCCESS) Then GoTo Err_Hnd
      
    tmpVal = Left$(tmpVal, InStr(tmpVal, Chr(0)) - 1)

    Select Case lKeyValType
        Case REG_SZ, REG_EXPAND_SZ
            sKeyVal = tmpVal
        Case REG_DWORD
            For i = Len(tmpVal) To 1 Step -1
                sKeyVal = sKeyVal + Hex(Asc(Mid(tmpVal, i, 1)))
            Next
            sKeyVal = Val(Format$("&h" + sKeyVal))
    End Select
    
    RegRead = sKeyVal
    RegCloseKey hkey

Exit Function
Err_Hnd:
    
    RegRead = vbNullString
    RegCloseKey hkey
    
End Function

Module3 code

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Any) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const GWL_WNDPROC As Long = (-4)
Public Const GWL_HWNDPARENT As Long = (-8)
Public Const GWL_ID As Long = (-12)
Public Const GWL_STYLE As Long = (-16)
Public Const GWL_EXSTYLE As Long = (-20)
Public Const GWL_USERDATA As Long = (-21)

Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
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 NIM_SETFOCUS = &H3
Public Const NIM_SETVERSION = &H4
Public Const NIM_VERSION = &H5

Public Const NIS_HIDDEN = &H1
Public Const NIS_SHAREDICON = &H2

Public Const WM_USER As Long = &H400
Public Const WM_MYHOOK As Long = WM_USER + 1
Public Const WM_NOTIFY As Long = &H4E
Public Const WM_COMMAND As Long = &H111
Public Const WM_CLOSE As Long = &H10
Public Const WM_MOUSEMOVE As Long = &H200
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202
Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_MBUTTONDOWN As Long = &H207
Public Const WM_MBUTTONUP As Long = &H208
Public Const WM_MBUTTONDBLCLK As Long = &H209
Public Const WM_RBUTTONDOWN As Long = &H204
Public Const WM_RBUTTONUP As Long = &H205
Public Const WM_RBUTTONDBLCLK As Long = &H206

Public Const NIN_BALLOONSHOW = (WM_USER + 2)
Public Const NIN_BALLOONHIDE = (WM_USER + 3)
Public Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Public Const NIN_BALLOONUSERCLICK = (WM_USER + 5)

Public Enum bFlag
    NIIF_NONE = &H0
    NIIF_INFO = &H1
    NIIF_WARNING = &H2
    NIIF_ERROR = &H3
    NIIF_GUID = &H5
    NIIF_ICON_MASK = &HF
    NIIF_NOSOUND = &H10
End Enum

Public 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
End Type
   
Global ni As NOTIFYICONDATA
Global lWP As Long


Private Sub UnSubClass(hwnd As Long)

   If lWP <> 0 Then
      SetWindowLong hwnd, GWL_WNDPROC, lWP
      lWP = 0
   End If
   
End Sub

Private Sub SubClass(hwnd As Long)

   On Error Resume Next
   lWP = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
   
End Sub

Public Sub TrayAdd(pb As PictureBox)
   
   With ni
      .cbSize = Len(ni)
      .hwnd = pb.hwnd
      .uID = 1
      .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
      .dwState = NIS_SHAREDICON
      .hIcon = pb.Picture
      .uCallbackMessage = WM_MYHOOK
      
      .szTip = "Tooltip title" & vbNullChar
      .uTimeoutAndVersion = NOTIFYICON_VERSION
   End With
   
   Shell_NotifyIcon NIM_ADD, ni
   
   SubClass pb.hwnd
       
End Sub

Public Sub TrayRemove(pb As PictureBox)
      
   With ni
      .cbSize = Len(ni)
      .hwnd = pb.hwnd
      .uID = 1
   End With
   
   Shell_NotifyIcon NIM_DELETE, ni
   
   UnSubClass pb.hwnd

End Sub

Public Sub TrayBalloon(pb As PictureBox, bTitle As String, bText As String, ByVal bFlag As bFlag)
   
   With ni
      .cbSize = Len(ni)
      .hwnd = pb.hwnd
      .uID = 1
      .uFlags = NIF_INFO
      .dwInfoFlags = bFlag

      .szInfoTitle = bTitle & vbNullChar
      .szInfo = bText & vbNullChar
   End With

   Shell_NotifyIcon NIM_MODIFY, ni

End Sub

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    On Error Resume Next
    Select Case hwnd
        Case frmBalloon.pbTray.hwnd
            Select Case uMsg
                Case WM_MYHOOK
                    Select Case lParam
                        Case WM_LBUTTONUP
                            'MsgBox "User has left-clicked the system tray icon", vbInformation, "Information"
                        Case WM_RBUTTONUP
                            'MsgBox "User has right-clicked the system tray icon", vbInformation, "Information"
                        Case NIN_BALLOONSHOW
                            'Msgbox "The balloon tip has just been displayed", vbInformation, "Information"
                        Case NIN_BALLOONHIDE
                            'MsgBox "The systray icon was removed when the balloon tip was displayed", vbInformation, "Information"
                        Case NIN_BALLOONUSERCLICK
                            MsgBox "User clicked the balloon tip", vbInformation, "Information"
                        Case NIN_BALLOONTIMEOUT
                            'MsgBox "The balloon tip either timed out or user clicked the close button", vbInformation, "Information"
                        Case WM_MOUSEMOVE
                            'MsgBox "User moved mouse over icon"
                    End Select
                Case Else
                    WindowProc = CallWindowProc(lWP, hwnd, uMsg, wParam, lParam)
                    Exit Function
            End Select
        Case Else
            WindowProc = CallWindowProc(lWP, hwnd, uMsg, wParam, lParam)
    End Select
   
End Function