Attribute VB_Name = "IconTray"
Option Explicit
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function DrawAnimatedRects Lib "user32" (ByVal hwnd As Long, ByVal idAni As Long, lprcFrom As RECT, lprcTo As RECT) As Long
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type
Public Type POINTAPI
    X As Long
    Y As Long
End Type
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const GW_CHILD = 5
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GWL_WNDPROC = (-4)
Private Const IDANI_OPEN = &H1
Private Const IDANI_CLOSE = &H2
Private Const IDANI_CAPTION = &H3
Private Const WM_USER = &H400
Private Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
'Mouse_Move X Constants
Private Const RightDoubleClick = 7770
Private Const LeftMouseUp = 7710
Private Const RightMouseUp = 7755
Private Const RightMouseDown = 7740
Private Const LeftDoubleClick = 7725
Private Const MouseMove = 7680
Private Const LeftMouseDown = 7695
Private TrayIcon As NOTIFYICONDATA
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLICK = &H203
Private Const WM_RBUTTONUP = &H205
Private Const WM_MOUSEMOVE = &H200
Private rctFrom As RECT
Private rctTo As RECT
Private lngTrayHand As Long
Private lngStartMenuHand As Long
Private lngChildHand As Long
Private strClass As String * 255
Private lngClassNameLen As Long
Private lngRetVal As Long
Public ExtentX As Long
Public ExtentY As Long
Public Ending As Boolean
Public MessageText As String
Public FreeForm As Boolean
Public Range As Integer

Public Sub GetRes()
ExtentX = GetSystemMetrics(SM_CXSCREEN)
ExtentY = GetSystemMetrics(SM_CYSCREEN)
End Sub

Public Function ReadOnly(ByVal Folder As String) As Boolean
On Error GoTo Out:
FileSystem.SetAttr Folder, vbNormal
ReadOnly = False
Exit Function
Out:
ReadOnly = True
End Function


Public Function Resize() As Single
Resize = ExtentX / 640
End Function

Public Function ResizeY() As Single

Select Case ExtentY
Case 480
ResizeY = 1
Case 600
ResizeY = 1
Case 768
ResizeY = 1
Case 800
ResizeY = 0.85
Case Is > 1049
ResizeY = 0.8
Case Else
ResizeY = 1
End Select
'Debug.Print "ResizeY = " & ResizeY
End Function
Public Function ResizeY1() As Single


Select Case Screen.Height  'resize for resoulution
Case 10800
ResizeY1 = 0.97
Case 16200
ResizeY1 = 0.97
Case Else
ResizeY1 = 1
End Select
End Function
Public Function ResizeX()
Select Case ExtentY
Case Is > 767
ResizeX = 1.05
Case Else
ResizeX = 1
End Select
End Function

Public Function ResizeY2() As Single
ResizeY2 = 1
Exit Function
Select Case Screen.Height  'resize for resoulution
Case 10800
ResizeY2 = 1.2
Case 16200
ResizeY2 = 1.2
Case Else
ResizeY2 = 1
End Select
End Function

Public Sub ChangeIcon(frm As Form, newIcon As Object)
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hwnd = frm.hwnd
TrayIcon.uID = vbNull
TrayIcon.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
TrayIcon.uCallbackMessage = WM_MOUSEMOVE
TrayIcon.hIcon = newIcon
TrayIcon.szTip = frm.Caption + Chr(0)
Shell_NotifyIcon 1, TrayIcon
End Sub

Public Sub ChangeToolTip(frm As Form, Tip As String)
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hwnd = frm.hwnd
TrayIcon.uID = vbNull
TrayIcon.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
TrayIcon.uCallbackMessage = WM_MOUSEMOVE
TrayIcon.hIcon = frm.Icon
TrayIcon.szTip = Tip + Chr(0)
Shell_NotifyIcon 1, TrayIcon
End Sub

Public Function TitleToTray(frm As Form)
lngStartMenuHand = FindWindow("Shell_TrayWnd", vbNullString)
lngChildHand = GetWindow(lngStartMenuHand, GW_CHILD)
Do
lngClassNameLen = GetClassName(lngChildHand, strClass, Len(strClass))
If InStr(1, strClass, "TrayNotifyWnd") Then
lngTrayHand = lngChildHand
Exit Do
End If
lngChildHand = GetWindow(lngChildHand, GW_HWNDNEXT)
Loop
lngRetVal = GetWindowRect(frm.hwnd, rctFrom)
lngRetVal = GetWindowRect(lngTrayHand, rctTo)
lngRetVal = DrawAnimatedRects(frm.hwnd, IDANI_OPEN Or IDANI_CAPTION, rctFrom, rctTo)
End Function

Public Function TrayToTitle(frm As Form)
lngStartMenuHand = FindWindow("Shell_TrayWnd", vbNullString)
lngChildHand = GetWindow(lngStartMenuHand, GW_CHILD)
Do
lngClassNameLen = GetClassName(lngChildHand, strClass, Len(strClass))
If InStr(1, strClass, "TrayNotifyWnd") Then
lngTrayHand = lngChildHand
Exit Do
End If
lngChildHand = GetWindow(lngChildHand, GW_HWNDNEXT)
Loop
lngRetVal = GetWindowRect(frm.hwnd, rctFrom)
lngRetVal = GetWindowRect(lngTrayHand, rctTo)
lngRetVal = DrawAnimatedRects(frm.hwnd, IDANI_CLOSE Or IDANI_CAPTION, rctTo, rctFrom)
End Function

Public Sub PlaceIcon(ByRef frm As Form)
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hwnd = frm.hwnd
TrayIcon.uID = vbNull
TrayIcon.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
TrayIcon.uCallbackMessage = WM_MOUSEMOVE
TrayIcon.hIcon = frm.Icon
TrayIcon.szTip = frm.Caption + Chr(0)
Shell_NotifyIcon 0, TrayIcon
End Sub

Public Sub DestroyIcon(frm As Form)
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hwnd = frm.hwnd
TrayIcon.uID = vbNull
TrayIcon.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
TrayIcon.uCallbackMessage = WM_MOUSEMOVE
TrayIcon.hIcon = frm.Icon
TrayIcon.szTip = Chr(0)
Shell_NotifyIcon 2, TrayIcon
End Sub
