Option Compare Database
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 Const 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
#If VBA7 Then
Private Type NOTIFYICONDATA
cbSize As Long
hwnd As LongPtr
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As LongPtr
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
#Else
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 If
#If VBA7 Then
Private Declare PtrSafe Function Shell_NotifyIcon Lib "shell32.dll" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As LongPtr, _
lpData As NOTIFYICONDATA) As LongPtr
Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" _
Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, _
lpdwHandle As Long) As Long
Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" _
Alias "GetFileVersionInfoA" _
(ByVal lptstrFilename As String, _
ByVal dwHandle As LongPtr, _
ByVal dwLen As LongPtr, _
lpData As Any) As Long
Private Declare PtrSafe Function VerQueryValue Lib "version.dll" _
Alias "VerQueryValueA" _
(pBlock As Any, _
ByVal lpSubBlock As String, _
lpBuffer As Any, _
nVerSize As Long) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As LongPtr)
#Else
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)
#End If
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&
#If VBA7 Then
Private Declare PtrSafe Function apiLoadImage Lib "user32" _
Alias "LoadImageA" _
(ByVal hInst As LongPtr, _
ByVal lpszName As String, _
ByVal uType As LongPtr, _
ByVal cxDesired As LongPtr, _
ByVal cyDesired As LongPtr, _
ByVal fuLoad As LongPtr) _
As Long
Private Declare PtrSafe Function apiSendMessageLong Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) _
As LongPtr
#Else
Private Declare Function apiLoadImage Lib "user32" _
Alias "LoadImageA" _
(ByVal hInst As Long, _
ByVal lpszName As String, _
ByVal uType 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
#End If
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 LongPtr
iIcon As LongPtr
dwAttributes As LongPtr
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
#If VBA7 Then
Private Declare PtrSafe Function apiSHGetFileInfo Lib "shell32.dll" _
Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As LongPtr, _
psfi As SHFILEINFO, _
ByVal cbSizeFileInfo As LongPtr, _
ByVal uFlags As LongPtr) _
As LongPtr
Private Declare PtrSafe Function apiDestroyIcon Lib "user32" _
Alias "DestroyIcon" _
(ByVal hIcon As LongPtr) _
As LongPtr
#Else
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
#End If
Private psfi As SHFILEINFO
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
#If VBA7 Then
Private Declare PtrSafe Function apiShowWindow Lib "user32" _
Alias "ShowWindow" _
(ByVal hwnd As LongPtr, _
ByVal nCmdShow As LongPtr) _
As LongPtr
#Else
Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" _
(ByVal hWnd As Long, _
ByVal nCmdShow As Long) _
As Long
#End If
Private Sub ShellTrayAdd()
Dim nID As NOTIFYICONDATA
If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
With nID
.cbSize = NOTIFYICONDATA_SIZE
.hwnd = Application.hWndAccessApp
.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_ADD, 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.hWndAccessApp
.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.hWndAccessApp
.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
Case Else
NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
End Select
End Sub
Private Function IsShellVersion(ByVal version As LongPtr) As Boolean
Dim nBufferSize As Long
Dim nUnused As Long
Dim lpBuffer As LongPtr
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 Function GetSelectedOptionIndex() As LongPtr
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.Number & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2"
Resume ExitHere
End Select
'Debug Only
Resume
End Function
