B64Encode (WinAce Archiver www.winace.com)

Content-Type: application/octet-stream; name="Truetray.zip";
Content-Transfer-Encoding: base64
Content-Disposition: attachment; filename="Truetray.zip"

begin-base64 664 Truetray.zip
UEsDBBQAAAAIAIIE1jb7nKM6jQUAAHcRAAANAAAAY2xzSW5UcmF5LmNsc61X227bOBB9D5B/GPih
cQA3SF8XKBa+KFlhfYMlJ+iTQUm0zS1NCiRl1/36DklZFzdeJ0CFILbIM4dzhsPh+CVYROFsCl8e
HmE47kfR7c0geA6ntzcAk4IbttQUvsLnLwB3sSqoHZ9TpZk2JOF26hFnptLUgw4zIoYMmMiY2Azo
luyZVCV2n0ylqDCRLFRKK8hvmEkcxYoITVLDpJjIjEK9Zl/g9Cz5j6bm9iaYjm5v+sYolhSGwstg
NSU762An5ToUyHLsnAGeuUwIt7AoJ6nFPhGu6RlqqCg5icUQnE/PFc1oygl+hNkFiuBHLjVtzN59
/iMPEkWGKANyDUNOtAaMUMHpX1Bpvr25vZnlNniAXnCWMmOH5ortCTq3W21fRfYPyzIqoK9hLMUG
7kbFbneEA+6fPEBhPV9LBSnhHBKSftdNe8EyazidxeHTt3A4m476cb8JSF6YZhg+ixpIySkRcBdq
MFsKLEW/9uX8kZq/m4baS0KzyChMJOd3kaAGCPZUGBSLvk3knnbv35pZ5t1BYYx0wkJh6IaqN4Ej
eRDXoaOED/Ht+5tI3IkY9WyJyDi122HsW2jlGWlDWJHNlcypMkd4psYjuvenyNuMB/D/vfFXH+EH
93aaDkRW0dilz5nHFbOgB89TLnDfWKFi9uucoE3EkHBuU4qtj3aqvbIXLSUHw3KbIE6zPmpDd2Aw
9dzuvq07ZjmqLne2rRunKtX6J769R69ndPCatS22JkR6//kJsNAUnA+3RH1Mdj/LGgls5Ln0B8RA
dNoGwKxwuhKKYaLuIKF/aMQ0rAvhalslKyoSQH63fy0JI5oUm4e+1uhGfa6qstWERlvK+QpLZCkB
puFk1R+Nej4ODWhNVNe3OsvQF6d3mWfEUH0us5Kv6JrT1KDQI6R4CDYWK9GwDIBUVn9Loo/ve1Ve
VzeZjbAAtQS2NSzoTu4vaGh55oF/zrNRMA7i4Fro/R62/W5Wanz1NX4VCmYY4ewnbflXV0y8814G
4Ou/t+k0cRiJDUP9CgikzgCzsueSNFUU13Ihyhp3QKmf7eCQ2vP1Oh25ZsGN49iDNkffDFQjPF+L
g8hyJVMcn+MqXUxqRbWerUvX8OKZ4/R9ZbMNhTZEuJu4n+f1e4NV/3SC/N1eSfaAky43hHA32rri
0GToJL46XcGP7mOvIuk1w+bwHSwRK2Q5fzoCPEGnB4+nvy+P/l9jaHB8IRweS4V1FHk+oa2a70Yq
5xZ03Z3Q0iqixq9lwS0xPXh+Ha+WUbCwV27PcbT2uUoUv6M+LcHmpeu9QBtVpKZQ3golmW2dpP55
SJMI7dG1MRVdN3lfz1aXx2NzDB3Eoaan9WxVgTuddvmtEYUtv7bNmFCtycau/TpxMlfRtyhe9L81
wU+cbDRCpuHTynYfMFPuexzOT18nQRT1n4OmVTiqncaz5qS/VTOeyuIMeisLnoEU/AiJr+C2K1Jy
BzuZlTljJNh8R7fLc6ORAnZehoYNFVQRU9q5LYl8HbLWrRI09zRlBLqHOVFkd8oY3OnWeyu9IuoK
8ZBoWsIq3X7w1ZZKjOZk9hK0U3tBmKZnndXvxuPBMo6xy5u9Ti+a113VPhnTtfEd0/1FsuX8/6mW
+TuJRoPxcPzvBbK6hbvGtvigxgXbbK+yXRd5nelDKq/STT4oc4KHmdNrdNd1voPqg0LbfPW59qfh
XbdqTNWOCWLOLtW7IZf60o0YUZGVZ7Rdma2G4XgWBc1r4FOL13cZdRPJ1sAM0B9MG+0h4brZIcTb
Zh2te5RKLOKbCyyFal6H9S13frW2K17setIPlb0DemZ1oDXERH8fEAVIoqjvJjLoMtoDJnBE51LY
aEoHTIgaesh9uwHzlq0W7FpILndT+Nh++kKsWuLt98s/pf/gz/ZfUEsDBBQAAAAIAL199zYkiP8f
kQUAACYPAAAJAAAARm9ybTEuZnJt1VffT9tWFH5H4n84zUuC1kZJCl2ZxqQQwohEATUUtCd0HV8S
C8e27OsC/euqSpWqTa3Uvexpkpvi4Saxsc2qbgKtO752sJuR0D1U066IHfuce853vvMjl536w2Zj
cwMWiqXS7MwybUsK7CwXV1W9C9GlDLMzAFAjGpNUBUZrCT85Ls/FclmiClujUrvDRvK7pcVSRrhO
91m6+V5WtK1qGbvzC1nZriSyTiq7n2xstDiaawAV9/Wj3DclXFxxXVIO0L7UmoC82SIyTYBnkafC
EYJxCM2OethQtolxIBA9EZbwk18lskFjFUZ09kjbUg2J08eNo8aupIjqoQErdJ+YMuO6V9xvS12q
A78m7EfxKozqj4mcjbfMieIrJTcDtFK6kqcMp/JYWFfET903uqRNQeq295h+5T4lKN1fmS+l6ER6
BGPiqdjuX+3dklrM1Om0TNZuDgPXjmRIgpwxNJ4PvtJsZiP5wlyUp3CBez+fi4XFe/93LqbW7Ocz
sVgp/VdMrBOBysCvaYNWTaY2pSc0a+FOGf1s62bsZtIY/dE7gf7ACgILQu+D64Frw5k3dP+CAPpW
33vrQWC9C61CoYA4FaKI8eQaQdrSVY3q7BjntcI4nmRtkC79x4xsdoksc1Ujl9FNoWdmdEZe6xDd
oOxTgkrzGY3da0phPp1AuB5hNeiypNCpqcDVYETmA/smxSbTpQPKOrpqtjsTFTGBI44m1u3N4zQt
NyLwus4Kp9fi1CpbrCxcX2YPqGKChvamVg8qlHP/ptjHPXQVczPxMcXNq7DvX4SXuQynE83Vj240
9+zivXcyZiy580uVYWYFk1G0u8freGn0qz0m/F5WBSJHKk2NtCI9HuuYVk2nhBFBniTf0qlIWzLB
W0NEHWzacZX6kaYaVEwN5J/2Qs8fte4d6NkDp38bsIGH2MH455z27CC0XSig8uu+d+b4Xs8awJn/
cYhCeONb56e2b4Fr8UYf3gnjVrdvw3svvITzN/a7dBq8PbHRzqvwIuhb6AQ34ZYzG4RjOORjAeZw
zc5Ezs6s4S0ouM5v9hw+dlVBaulknxUN1dRbdF/V27SoUIaoQ4To+OfoFDT5CdjBwMELOu/59vAj
OKgwsH/3XCh/fe+oUiml1nsXf9jc3WacYCQIu1bC08yWKeA3LHfWqT+mOGmQT3IMVQNastFQoocM
uVxYRIZ3iL5GZa2xAks4OtGMLj0mKF+JMwOrptLinpqUYS3QNra9IsZnKViXBMiZBtXvVnJQWD7e
ITJ0dhUx8rquKu250ZfZmRWpG50foxfLx2g//9Ib2j4G2j//EwnvW37ouH0HehD6th3rywZDY02W
bkr8NhlhWAwp2qYp8JPz3rpKxAIShGjj+Jdggx5mKeCBV0URwSjIK3/sRA+oGt2Ka5hVmSaK25IW
dcEaPb4FjXwXqor4sPoDkAMCu1f5z/EGikBci+khNXDQR6jyz1//9AKCnudbH5yeZQ/h51cQYJPz
7y9ePv3lOZxaWHmOG70IvCD0ProO0tHYhzh2HjpCKsN2hyqwJokU6tgaKVlLWc2JyPjI2KthyRxE
yB4pMjIHD6Zu2NSSDTwULFoMxfbd89CLOtELgtByrd4gjszrY7842EZ96zSOz37rTQxk7CVWfHTS
nwQmOajv8VuEJpvF5LhUwKe5YnKkGSUV3fMq/PY7qHC//GmJX7+CMmcyeVWa7Byd7a0IcszFsskY
uq0a/N+FNtUjcp5lychmMqLFggJOHjizffskLQYUDufAKRaLszOfkJFmNl8VjEINO7OwoTKoLauq
XMioYiXGtEEerYwRPzWYByo28Yp6qFwbDXKWvE5pqx9JLDZ33VzgMyD/K9bFh9B7A0MbJ6nr+UNr
cOl6ScEPvOCSB7ulaqY2+t3N4PwbUEsDBBQAAAAIAL199zaH2cD4bAEAAKoMAAAJAAAARm9ybTEu
ZnJ47ZQxS8NQFIVPCIU6ROoiOuno7/FXdJAMRYIZ6taCXTIkSx0yZBE6ZBCLkDHgEreaqegiCIKT
uLi06W1SXmOubYJWzJCvpyXn8TXJJeTVAZycIqZbS47PayAk+jQaoN86mrSyC+AIAC3hEMk6EnGJ
tOyqqqLVakHTNOi6jna7jU6ng16vB8MwYJomLMtCv9+HbdtwHAeDwQCu62I4HMLzPPi+jyAIMBqN
EIYhxuMxoihCyamoqJBiUn2LWNcVgvXUqbYJaXEoUBQ6ibSzoGBPmPfUTSYdgsKdz/t5wL/grHS7
8mInlr/uxHtoymwnjtdjZOQRHe9nkutPL89E/sS/uhD5vc8HnN7aIlTXCzzJhcQ489xdf5t/8XnS
fu7j5j4YZfbXDVjuN7F242WS6+P+QaSQHz6JFPIfX0QK+c9vIlTzB3x9F6HKI31MVoX+QlehG6NZ
aPwf+pMJy8Z8nrSf+7i5D0bJ/Uw2/CbOAFBLAwQUAAAACACCBNY2QU4zlPEFAAAPFQAADQAAAG1v
ZEluVHJheS5iYXO9WFlvIkcQfrfk/1DiIYbEu/LazuaQrGg4bKNwicFG+4SamQImHrpRd48x/vXp
Y3DPBayUVXiCOr766ujqGTwpeTRPJMJzczYga4Q7qK1Z2KUTTna187OLTz/ko4B8SbgEtoA+C5MY
/4SPMOdn52fDjYwYhc7bJo6CSGrRxTSiIdsK8EbdC3F+1sYgJhzhPqGBMR7jMhISeSsmQkAvmkMt
EchvrmvgxRERUMtZeDWYnZ9B+qlbL0/AdNBu9Tzfb+gfPUaXFaFaHIlES6jzVhkrb1II1tw9kxhC
pfDlLsZ9pEuwinhj2KgGGJWvmuKUDkfZWfyyoYWvBH9zAgeV6nZFYzqNQrkqSR8xWq7kEaDVlIYj
wpE6o72mjzQpCbtUSEIDzCA5m3ijoMhaCzy6O9YXH+U947jkLKGhrU2+OXVHbw/TKMWshl5hHM8G
TEaLXTdg1OIKLb25/hzGcdr5LFqt6OTVXO/7KARZYjbNNpEEvBzEYDjp3n/rtoaDtjfxXO6Hx9+m
naLnsy8TrHRyLOONHSk3XCeqb3G0vvJQ5CwKZ8J1pjRuXRriW1EabgdocAoVU6ITLGl4pDo1p3eF
yOBXMtz2xbIks0Pr2mt+Z5FOz3OLbXZ9XDO+s1RfkFOMsxtNxn32itamim2IonQEBQ9KGwfp0p3z
Y5QeTjb54T81+TSDNi4s/oizoJJBzuIkg9NNPLLobFe/h/YT5ScvqIJNkfrpy8Et0jKj87PJboOF
jWLhg7kfvaMzdXOelSTddkFwH5OlKMhaJI7nJHixZ6gIqrdgXiTeJ9HGZQI/w9fb87OOCq7p7ml/
XMupk7rZCtDxZkG3NNyoljuFTa4VC3yTnBTlKsOOll/nFK6IJ7mvWgkXjBeEc95U+dtLqMhRvOv7
TzevrKnoa74Qo2QeR4HaCoofDLr9mdduwx389HhVoesP26rPRv2lQt3u9DqTjlFfl9T3s37H972H
jnMv6PX8HHSedEdGd1vQTfuzJ78ztrqrK5t5wULxVja9jvfc2VfIxvFujthPHzudXt7+Ss12pW1/
qKCtyVXZpNd8mkzU2RhOB6nRl4NGT6PU5PowTrPX6v2dmt2UzcalcLeHjFy4X6tMyuG+VhSgFO63
Q0Yu3O9VJuVwf1R3e+Z/8ydjT03iR/9/gYoMWr2hn85bsS0P055x1AtLWdQ/XX9pmFeCR/KKsEWI
aCQjEqsdpg4LES9zwscozBvGDuVfCo5Hr0QirGfzdC91lQua49lkLEZCM28Ya2sCAqkElkjYrpCC
XCFICw6RAG4DYKgcoR7hLRAaQrJpZKMleTbZZXzRTtbrHSz294NkoDYn24IXhgpbDBdGJES0tEp4
JTwi8xj31XF3y0iZ1WnFzgcAo1RVo2aXfPgYCmOUCacK+rkJbP4PBhI2LKK6MPMd0JH5zsvx2jjG
RX2vz8UNYmFf40zw7BPMM+EjyevGt3GZ/vwAUZLbCob2NUoASYlxUwrHt8zNeBh+yiLHyNXlADXj
mqenMA4wa6OQnO1ErnqBQrDVszWCOlNjw7eRQD0/yvJC6HkBjgvkqO+YgCVUTRhLYuWmRzlgnCus
xkdqfjKHNJopu4r1UXKbSjtaAz2YnXZw9XbpKFyTyUQR29qXJX17YphwhAXjhnFoptSqhZIQ6Qqa
pivKTbB6/RKoAI88cyV9sax4uqp++jr+yGV9XT3izdDVyYmLQ5F16y5gwGR5SagCUfccpoWp3gpV
LZVrFsjHWE9Diwg0KTrnC30aS6tRMl1rRyodJ+emkYpeSus+abp3+efzuq75ZW5/NvJuPkpgxtGe
aQNTsFH6z7qPKuc077Qz+5eavLkb1ewhypSgu9DZmkXdJHy/SIVCw+xwvVA1kGSu929UKEV5s/6v
xRijHXz9QPj9uasxSQcjMyr5kwJ3+bcbS9mM0GWh5ilo5VK3rxCmyNvClZZWrZXuKcH09RkQClsi
g5U59ZF0N9geODv09UaGf/mw3MGEJ5g1KV+Dd9X/VtRreXq1w0kqQeWfhz/uL0oV5V9QSwMEFAAA
AAgAvX33NlfsM4S2AQAAzwIAAAwAAABQcm9qZWN0MS52YnBVUU1vm0AQvSPxHyx8aSsVERz10IiD
C6FFqgHVrn1BshYYkk33A+2HY1L1v3cXKFY5jN68N7Mz8zgMPUSPV3CdlAsa2XDnd4K6zg/oQABr
IPpQff0dBEEY3G+CjwbMIR7R8t1/+rMO/WAdrOPP1SnLk+K0r+QgFdBNWEnVcgKhr0i9Lr4/rrZa
cYoU5sx1YoKkjBoiM3YQaHhYLdA3yHV2vNUEIsrbfwUL9Gt0KzAEk31enB5Wvl+dkb5igpEYzlLp
rjtXk45MbObGrOFsvNsbD/dcZ6+QULq/ETGnFLF2E0aeyXJEIfJKwV+gUVb+BqSPOVNwVVkSecHU
0ZvLagJmL5i4HXrh4ggiujMYswkH1uQLlsaEObWuZKwRQIGpmduDuIDY677nQqWYgLSsEW3fOIsN
01rJbjuPx2S01v5cW1z0ClP89h+XogsXpRmDNTX3vFP0vaVjs/IRw2sCtX7KWMctmfOtMVJi9mSz
L1yzVsbP0PwaHzfbdYS/LkRKSo6ZuuVJdlySn0zYdmjT0qST3damSUNKgRUnaxTCbMKHZwGoLUEU
tTXeUjt0zTWtDdVNqrTe/gVQSwMEFAAAAAgAwn33NuBpcHtzAAAAmQAAAAwAAABQcm9qZWN0MS52
Ync9zDEKwzAMBdC90DvoABoixZacoVOgkKVdCp1LO9ZOSabcvt8mZPkC/Sdd5yULXUikYxJLTEn7
PZh0wBDH1kWYYgQaz6f3d53KY3ltOAzOZApgXVXeQJ4/B5BeIerPEKtITaAs6+92f0KYoXR0PiCC
NvAHUEsBAhQAFAAAAAgAggTWNvucozqNBQAAdxEAAA0AAAAAAAAAAAAgCAAAAAAAAGNsc0luVHJh
eS5jbHNQSwECFAAUAAAACAC9ffc2JIj/H5EFAAAmDwAACQAAAAAAAAAAACAIAAC4BQAARm9ybTEu
ZnJtUEsBAhQAFAAAAAgAvX33NofZwPhsAQAAqgwAAAkAAAAAAAAAAAAgCAAAcAsAAEZvcm0xLmZy
eFBLAQIUABQAAAAIAIIE1jZBTjOU8QUAAA8VAAANAAAAAAAAAAAAIAgAAAMNAABtb2RJblRyYXku
YmFzUEsBAhQAFAAAAAgAvX33NlfsM4S2AQAAzwIAAAwAAAAAAAAAAAAgCAAAHxMAAFByb2plY3Qx
LnZicFBLAQIUABQAAAAIAMJ99zbgaXB7cwAAAJkAAAAMAAAAAAAAAAAAIAgAAP8UAABQcm9qZWN0
MS52YndQSwUGAAAAAAYABgBYAQAAnBUAAAAA

end
5898 bytes

VERSION 5.00
Begin VB.Form frmSysTray
   Caption         =   "Sys Tray Interface"
   ClientHeight    =   1920
   ClientLeft      =   5610
   ClientTop       =   3360
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   1920
   ScaleWidth      =   4680
   Begin VB.Menu mnuPopup
      Caption         =   "&Popup"
      Begin VB.Menu mnuSysTray
         Caption         =   ""
         Index           =   0
      End
   End
End
Attribute VB_Name = "frmSysTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' 03/03/2003
' * Added Unicode support
' * Added support for new tray version (ME,2000 or above required)
' * Added support for balloon tips (ME,2000 or above required)

' frmSysTray.
' Steve McMahon
' Original version based on code supplied from Ben Baird:

'Author:
'        Ben Baird <psyborg@cyberhighway.com>
'        Copyright (c) 1997, Ben Baird
'
'Purpose:
'        emonstrates setting an icon in the taskbar's
'        system tray without the overhead of subclassing
'        to receive events.

Private Declare Function Shell_NotifyIconA Lib "shell32.dll" _
   ByVal dwMessage As Long, lpData As NOTIFYICONDATAA) As Long
   
Private Declare Function Shell_NotifyIconW Lib "shell32.dll" _
   ByVal dwMessage As Long, lpData As NOTIFYICONDATAW) As Long


Private Const NIF_ICON = &H2
Private Const NIF_MESSAGE = &H1
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 NOTIFYICON_VERSION = 3

Private Type NOTIFYICONDATAA
   cbSize As Long             ' 4
   hwnd As Long               ' 8
   uID As Long                ' 12
   uFlags As Long             ' 16
   uCallbackMessage As Long   ' 20
   hIcon As Long              ' 24
   szTip As String * 128      ' 152
   dwState As Long            ' 156
   dwStateMask As Long        ' 160
   szInfo As String * 256     ' 416
   uTimeOutOrVersion As Long  ' 420
   szInfoTitle As String * 64 ' 484
   dwInfoFlags As Long        ' 488
   guidItem As Long           ' 492
End Type
Private Type NOTIFYICONDATAW
   cbSize As Long             ' 4
   hwnd As Long               ' 8
   uID As Long                ' 12
   uFlags As Long             ' 16
   uCallbackMessage As Long   ' 20
   hIcon As Long              ' 24
   szTip(0 To 255) As Byte    ' 280
   dwState As Long            ' 284
   dwStateMask As Long        ' 288
   szInfo(0 To 511) As Byte   ' 800
   uTimeOutOrVersion As Long  ' 804
   szInfoTitle(0 To 127) As Byte ' 932
   dwInfoFlags As Long        ' 936
   guidItem As Long           ' 940
End Type


Private nfIconDataA As NOTIFYICONDATAA
Private nfIconDataW As NOTIFYICONDATAW

Private Const NOTIFYICONDATAA_V1_SIZE_A = 88
Private Const NOTIFYICONDATAA_V1_SIZE_U = 152
Private Const NOTIFYICONDATAA_V2_SIZE_A = 488
Private Const NOTIFYICONDATAA_V2_SIZE_U = 936

Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205

Private Const WM_USER = &H400

Private Const NIN_SELECT = WM_USER
Private Const NINF_KEY = &H1
Private Const NIN_KEYSELECT = (NIN_SELECT Or NINF_KEY)
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)

' Version detection:
Private Declare Function GetVersion Lib "kernel32" () As Long

Public Event SysTrayMouseDown(ByVal eButton As MouseButtonConstants)
Public Event SysTrayMouseUp(ByVal eButton As MouseButtonConstants)
Public Event SysTrayMouseMove()
Public Event SysTrayDoubleClick(ByVal eButton As MouseButtonConstants)
Public Event MenuClick(ByVal lIndex As Long, ByVal sKey As String)
Public Event BalloonShow()
Public Event BalloonHide()
Public Event BalloonTimeOut()
Public Event BalloonClicked()

Public Enum EBalloonIconTypes
   NIIF_NONE = 0
   NIIF_INFO = 1
   NIIF_WARNING = 2
   NIIF_ERROR = 3
   NIIF_NOSOUND = &H10
End Enum

Private m_bAddedMenuItem As Boolean
Private m_iDefaultIndex As Long

Private m_bUseUnicode As Boolean
Private m_bSupportsNewVersion As Boolean

Public Sub ShowBalloonTip( _
      ByVal sMessage As String, _
      Optional ByVal sTitle As String, _
      Optional ByVal eIcon As EBalloonIconTypes, _
      Optional ByVal lTimeOutMs = 30000 _
   
Dim lR As Long
   If (m_bSupportsNewVersion) Then
      If (m_bUseUnicode) Then
         stringToArray sMessage, nfIconDataW.szInfo, 512
         stringToArray sTitle, nfIconDataW.szInfoTitle, 128
         nfIconDataW.uTimeOutOrVersion = lTimeOutMs
         nfIconDataW.dwInfoFlags = eIcon
         nfIconDataW.uFlags = NIF_INFO
         lR = Shell_NotifyIconW(NIM_MODIFY, nfIconDataW)
      Else
         nfIconDataA.szInfo = sMessage
         nfIconDataA.szInfoTitle = sTitle
         nfIconDataA.uTimeOutOrVersion = lTimeOutMs
         nfIconDataA.dwInfoFlags = eIcon
         nfIconDataA.uFlags = NIF_INFO
         lR = Shell_NotifyIconA(NIM_MODIFY, nfIconDataA)
      End If
   Else
      ' can't do it, fail silently.
   End If
End Sub

Public Property Get ToolTip() As String
Dim sTip As String
Dim iPos As Long
    sTip = nfIconDataA.szTip
    iPos = InStr(sTip, Chr$(0))
    If (iPos <> 0) Then
        sTip = Left$(sTip, iPos - 1)
    End If
    ToolTip = sTip
End Property
Public Property Let ToolTip(ByVal sTip As String)
   If (m_bUseUnicode) Then
      stringToArray sTip, nfIconDataW.szTip, unicodeSize(IIf(m_bSupportsNewVersion, 128, 64))
      nfIconDataW.uFlags = NIF_TIP
      Shell_NotifyIconW NIM_MODIFY, nfIconDataW
   Else
      If (sTip & Chr$(0) <> nfIconDataA.szTip) Then
         nfIconDataA.szTip = sTip & Chr$(0)
         nfIconDataA.uFlags = NIF_TIP
         Shell_NotifyIconA NIM_MODIFY, nfIconDataA
      End If
   End If
End Property

Public Property Get IconHandle() As Long
    IconHandle = nfIconDataA.hIcon
End Property
Public Property Let IconHandle(ByVal hIcon As Long)
   If (m_bUseUnicode) Then
      If (hIcon <> nfIconDataW.hIcon) Then
         nfIconDataW.hIcon = hIcon
         nfIconDataW.uFlags = NIF_ICON
         Shell_NotifyIconW NIM_MODIFY, nfIconDataW
      End If
   Else
      If (hIcon <> nfIconDataA.hIcon) Then
         nfIconDataA.hIcon = hIcon
         nfIconDataA.uFlags = NIF_ICON
         Shell_NotifyIconA NIM_MODIFY, nfIconDataA
      End If
   End If
End Property

Public Function AddMenuItem(ByVal sCaption As String, Optional ByVal sKey As String = "", Optional ByVal bDefault As Boolean = False) As Long
Dim iIndex As Long
    If Not (m_bAddedMenuItem) Then
        iIndex = 0
        m_bAddedMenuItem = True
    Else
        iIndex = mnuSysTray.UBound + 1
        Load mnuSysTray(iIndex)
    End If
    mnuSysTray(iIndex).Visible = True
    mnuSysTray(iIndex).Tag = sKey
    mnuSysTray(iIndex).Caption = sCaption
    If (bDefault) Then
        m_iDefaultIndex = iIndex
    End If
    AddMenuItem = iIndex
End Function

Private Function ValidIndex(ByVal lIndex As Long) As Boolean
    ValidIndex = (lIndex >= mnuSysTray.LBound And lIndex <= mnuSysTray.UBound)
End Function

Public Sub EnableMenuItem(ByVal lIndex As Long, ByVal bState As Boolean)
    If (ValidIndex(lIndex)) Then
        mnuSysTray(lIndex).Enabled = bState
    End If
End Sub

Public Function RemoveMenuItem(ByVal iIndex As Long) As Long
Dim i As Long
   If ValidIndex(iIndex) Then
      If (iIndex = 0) Then
         mnuSysTray(0).Caption = ""
      Else
         ' remove the item:
         For i = iIndex + 1 To mnuSysTray.UBound
            mnuSysTray(iIndex - 1).Caption = mnuSysTray(iIndex).Caption
            mnuSysTray(iIndex - 1).Tag = mnuSysTray(iIndex).Tag
         Next i
         Unload mnuSysTray(mnuSysTray.UBound)
      End If
   End If
End Function

Public Property Get DefaultMenuIndex() As Long
   efaultMenuIndex = m_iDefaultIndex
End Property

Public Property Let DefaultMenuIndex(ByVal lIndex As Long)
   If (ValidIndex(lIndex)) Then
      m_iDefaultIndex = lIndex
   Else
      m_iDefaultIndex = 0
   End If
End Property

Public Function ShowMenu()
   SetForegroundWindow Me.hwnd
   If (m_iDefaultIndex > -1) Then
      Me.PopupMenu mnuPopup, 0, , , mnuSysTray(m_iDefaultIndex)
   Else
      Me.PopupMenu mnuPopup, 0
   End If
End Function

Private Sub Form_Load()
   ' Get version:
   Dim lMajor As Long
   Dim lMinor As Long
   Dim bIsNt As Long
   GetWindowsVersion lMajor, lMinor, , , bIsNt

   If (bIsNt) Then
      m_bUseUnicode = True
      If (lMajor >= 5) Then
         ' 2000 or XP
         m_bSupportsNewVersion = True
      End If
   ElseIf (lMajor = 4) And (lMinor = 90) Then
      ' Windows ME
      m_bSupportsNewVersion = True
   End If
   
   
   'Add the icon to the system tray...
   Dim lR As Long
   
   If (m_bUseUnicode) Then
      With nfIconDataW
         .hwnd = Me.hwnd
         .uID = Me.Icon
         .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
         .uCallbackMessage = WM_MOUSEMOVE
         .hIcon = Me.Icon.Handle
         stringToArray App.FileDescription, .szTip, unicodeSize(IIf(m_bSupportsNewVersion, 128, 64))
         If (m_bSupportsNewVersion) Then
            .uTimeOutOrVersion = NOTIFYICON_VERSION
         End If
         .cbSize = nfStructureSize
      End With
      lR = Shell_NotifyIconW(NIM_ADD, nfIconDataW)
      If (m_bSupportsNewVersion) Then
         Shell_NotifyIconW NIM_SETVERSION, nfIconDataW
      End If
   Else
      With nfIconDataA
         .hwnd = Me.hwnd
         .uID = Me.Icon
         .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
         .uCallbackMessage = WM_MOUSEMOVE
         .hIcon = Me.Icon.Handle
         .szTip = App.FileDescription & Chr$(0)
         If (m_bSupportsNewVersion) Then
            .uTimeOutOrVersion = NOTIFYICON_VERSION
         End If
         .cbSize = nfStructureSize
      End With
      lR = Shell_NotifyIconA(NIM_ADD, nfIconDataA)
      If (m_bSupportsNewVersion) Then
         lR = Shell_NotifyIconA(NIM_SETVERSION, nfIconDataA)
      End If
   End If
   
End Sub

Private Sub stringToArray( _
      ByVal sString As String, _
      bArray() As Byte, _
      ByVal lMaxSize As Long _
   
Dim b() As Byte
Dim i As Long
Dim j As Long
   If Len(sString) > 0 Then
      b = sString
      For i = LBound(b) To UBound(b)
         bArray(i) = b(i)
         If (i = (lMaxSize - 2)) Then
            Exit For
         End If
      Next i
      For j = i To lMaxSize - 1
         bArray(j) = 0
      Next j
   End If
End Sub
Private Function unicodeSize(ByVal lSize As Long) As Long
   If (m_bUseUnicode) Then
      unicodeSize = lSize * 2
   Else
      unicodeSize = lSize
   End If
End Function

Private Property Get nfStructureSize() As Long
   If (m_bSupportsNewVersion) Then
      If (m_bUseUnicode) Then
         nfStructureSize = NOTIFYICONDATAA_V2_SIZE_U
      Else
         nfStructureSize = NOTIFYICONDATAA_V2_SIZE_A
      End If
   Else
      If (m_bUseUnicode) Then
         nfStructureSize = NOTIFYICONDATAA_V1_SIZE_U
      Else
         nfStructureSize = NOTIFYICONDATAA_V1_SIZE_A
      End If
   End If
End Property

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim lX As Long
   ' VB manipulates the x value according to scale mode:
   ' we must remove this before we can interpret the
   ' message windows was trying to send to us:
   lX = ScaleX(x, Me.ScaleMode, vbPixels)
   Select Case lX
   Case WM_MOUSEMOVE
      RaiseEvent SysTrayMouseMove
   Case WM_LBUTTONUP
      RaiseEvent SysTrayMouseDown(vbLeftButton)
   Case WM_LBUTTONUP
      RaiseEvent SysTrayMouseUp(vbLeftButton)
   Case WM_LBUTTONDBLCLK
      RaiseEvent SysTrayDoubleClick(vbLeftButton)
   Case WM_RBUTTONDOWN
      RaiseEvent SysTrayMouseDown(vbRightButton)
   Case WM_RBUTTONUP
      RaiseEvent SysTrayMouseUp(vbRightButton)
   Case WM_RBUTTONDBLCLK
      RaiseEvent SysTrayDoubleClick(vbRightButton)
   Case NIN_BALLOONSHOW
      RaiseEvent BalloonShow
   Case NIN_BALLOONHIDE
      RaiseEvent BalloonHide
   Case NIN_BALLOONTIMEOUT
      RaiseEvent BalloonTimeOut
   Case NIN_BALLOONUSERCLICK
      RaiseEvent BalloonClicked
   End Select

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   If (m_bUseUnicode) Then
      Shell_NotifyIconW NIM_DELETE, nfIconDataW
   Else
      Shell_NotifyIconA NIM_DELETE, nfIconDataA
   End If
End Sub

Private Sub mnuSysTray_Click(Index As Integer)
   RaiseEvent MenuClick(Index, mnuSysTray(Index).Tag)
End Sub

Private Sub GetWindowsVersion( _
      Optional ByRef lMajor = 0, _
      Optional ByRef lMinor = 0, _
      Optional ByRef lRevision = 0, _
      Optional ByRef lBuildNumber = 0, _
      Optional ByRef bIsNt = False _
   
Dim lR As Long
   lR = GetVersion()
   lBuildNumber = (lR And &H7F000000) \ &H1000000
   If (lR And &H80000000) Then lBuildNumber = lBuildNumber Or &H80
   lRevision = (lR And &HFF0000) \ &H10000
   lMinor = (lR And &HFF00& \ &H100
   lMajor = (lR And &HFF)
   bIsNt = ((lR And &H80000000) = 0)
End Sub

VERSION 5.00
Begin VB.Form frmDemo
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "SysTray Sample Application"
   ClientHeight    =   4125
   ClientLeft      =   4920
   ClientTop       =   1785
   ClientWidth     =   5790
   Icon            =   "fDemo.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4125
   ScaleWidth      =   5790
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdShowBalloon
      Caption         =   "Show In&foTip"
      Height          =   495
      Left            =   180
      TabIndex        =   6
      Top             =   3420
      Width           =   1395
   End
   Begin VB.OptionButton optIcon
      Caption         =   "&Stimpy"
      Height          =   375
      Index           =   2
      Left            =   660
      TabIndex        =   5
      Top             =   2760
      Width           =   1335
   End
   Begin VB.OptionButton optIcon
      Caption         =   "&Tooth Beaver"
      Height          =   375
      Index           =   1
      Left            =   660
      TabIndex        =   4
      Top             =   2220
      Width           =   1335
   End
   Begin VB.OptionButton optIcon
      Caption         =   "&Bob"
      Height          =   375
      Index           =   0
      Left            =   660
      TabIndex        =   3
      Top             =   1620
      Value           =   -1  'True
      Width           =   1335
   End
   Begin VB.CheckBox chkSysTray
      Caption         =   "&Show in Systray"
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   1200
      Value           =   1  'Checked
      Width           =   4455
   End
   Begin VB.Image imgIcon
      Height          =   480
      Index           =   2
      Left            =   120
      Picture         =   "fDemo.frx":08CA
      Top             =   2700
      Width           =   480
   End
   Begin VB.Image imgIcon
      Height          =   480
      Index           =   1
      Left            =   120
      Picture         =   "fDemo.frx":148C
      Top             =   2100
      Width           =   480
   End
   Begin VB.Image imgIcon
      Height          =   480
      Index           =   0
      Left            =   120
      Picture         =   "fDemo.frx":1D56
      Top             =   1560
      Width           =   480
   End
   Begin VB.Image imgLogo
      Height          =   660
      Left            =   120
      Picture         =   "fDemo.frx":2620
      Top             =   120
      Width           =   2535
   End
   Begin VB.Label lblDetail
      BackStyle       =   0  'Transparent
      Caption         =   "VB Source Code and Tips at http://vbaccelerator.com/"
      BeginProperty Font
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   495
      Left            =   2760
      TabIndex        =   1
      Top             =   240
      Width           =   2835
   End
   Begin VB.Label lblBlack
      BackColor       =   &H00000000&
      BorderStyle     =   1  'Fixed Single
      Height          =   795
      Left            =   60
      TabIndex        =   2
      Top             =   60
      Width           =   5655
   End
End
Attribute VB_Name = "frmDemo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private WithEvents m_frmSysTray As frmSysTray
Attribute m_frmSysTray.VB_VarHelpID = -1

Private Sub SetIcon()
    Select Case True
    Case optIcon(0).Value
        m_frmSysTray.IconHandle = imgIcon(0).Picture.Handle
    Case optIcon(1).Value
        m_frmSysTray.IconHandle = imgIcon(1).Picture.Handle
    Case optIcon(2).Value
        m_frmSysTray.IconHandle = imgIcon(2).Picture.Handle
    End Select
End Sub

Private Sub chkSysTray_Click()
    If (chkSysTray.Value = Checked) Then
        Set m_frmSysTray = New frmSysTray
        With m_frmSysTray
            .AddMenuItem "&Open SysTray Sample", "open", True
            .AddMenuItem "-"
            .AddMenuItem "&vbAccelerator on the Web", "vbAccelerator"
            .AddMenuItem "&About...", "About"
            .AddMenuItem "-"
            .AddMenuItem "&Close", "close"
            .ToolTip = "SysTray Sample!"
        End With
        SetIcon
    Else
        Unload m_frmSysTray
        Set m_frmSysTray = Nothing
    End If
End Sub

Private Sub cmdShowBalloon_Click()
   m_frmSysTray.ShowBalloonTip _
      "Hello from vbAccelerator.com.  This SysTray form allows Unicode text and balloon tips.", _
      "vbAccelerator SysTray Sample", _
      NIIF_INFO
End Sub

Private Sub Form_Load()
    chkSysTray_Click
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Unload m_frmSysTray
    Set m_frmSysTray = Nothing
End Sub

Private Sub m_frmSysTray_MenuClick(ByVal lIndex As Long, ByVal sKey As String)
   Select Case sKey
   Case "open"
      Me.Show
      Me.ZOrder
   Case "close"
      Unload Me
   Case Else
      MsgBox "Clicked item with key " & sKey, vbInformation
   End Select
    
End Sub

Private Sub m_frmSysTray_SysTrayDoubleClick(ByVal eButton As MouseButtonConstants)
    Me.Show
    Me.ZOrder
End Sub

Private Sub m_frmSysTray_SysTrayMouseDown(ByVal eButton As MouseButtonConstants)
    If (eButton = vbRightButton) Then
        m_frmSysTray.ShowMenu
    End If
End Sub

Private Sub optIcon_Click(Index As Integer)
    SetIcon
End Sub