home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Mikes_MP3_1935449252005.psc / ctlSysTray.ctl < prev    next >
Text File  |  2005-09-15  |  12KB  |  313 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ctlSysTrayIcon 
  3.    BackColor       =   &H00C0C0C0&
  4.    CanGetFocus     =   0   'False
  5.    ClientHeight    =   435
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   390
  9.    InvisibleAtRuntime=   -1  'True
  10.    ScaleHeight     =   435
  11.    ScaleWidth      =   390
  12. End
  13. Attribute VB_Name = "ctlSysTrayIcon"
  14. Attribute VB_GlobalNameSpace = False
  15. Attribute VB_Creatable = True
  16. Attribute VB_PredeclaredId = False
  17. Attribute VB_Exposed = False
  18. Option Explicit
  19. Private m_ToolTipText             As String * 64
  20. Private m_Icon                    As Picture
  21. Private m_Visible                 As Boolean
  22. Private Type NOTIFYICONDATA
  23.     cbSize                            As Long
  24.     hwnd                              As Long
  25.     uId                               As Long
  26.     uFlags                            As Long
  27.     ucallbackMessage                  As Long
  28.     hIcon                             As Long
  29.     szTip                             As String * 64
  30. End Type
  31. Private mTrayIcon                 As NOTIFYICONDATA
  32. Private Const NIM_ADD             As Long = &H0
  33. Private Const NIM_MODIFY          As Long = &H1
  34. Private Const NIM_DELETE          As Long = &H2
  35. Private Const NIF_MESSAGE         As Long = &H1
  36. Private Const NIF_ICON            As Long = &H2
  37. Private Const NIF_TIP             As Long = &H4
  38. Private Const WM_MOUSEMOVE        As Long = &H200
  39. Private Const WM_LBUTTONDOWN      As Long = &H201
  40. Private Const WM_LBUTTONUP        As Long = &H202
  41. Private Const WM_LBUTTONDBLCLK    As Long = &H203
  42. Private Const WM_RBUTTONDOWN      As Long = &H204
  43. Private Const WM_RBUTTONUP        As Long = &H205
  44. Private Const WM_RBUTTONDBLCLK    As Long = &H206
  45. 'Various events that are generated
  46. Public Event MouseMoved()
  47. Public Event LeftButtonDown()
  48. Public Event LeftButtonUp()
  49. Public Event RightButtonDown()
  50. Public Event RightButtonUp()
  51. Public Event RightButtonDoubleClick()
  52. Public Event LeftButtonDoubleClick()
  53. Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
  54.                                                                                    pnid As NOTIFYICONDATA) As Boolean
  55. Private Sub AddSystemTray() ' Add the Icon in the Tray
  56.     On Error GoTo ErrorTrap
  57.     With mTrayIcon
  58.         .cbSize = Len(mTrayIcon)
  59.         .hwnd = UserControl.hwnd
  60.         .uId = vbNull '1&
  61.         .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
  62.         .ucallbackMessage = WM_MOUSEMOVE
  63.     End With 'mTrayIcon
  64.     If PictureType(m_Icon) = vbPicTypeIcon Then
  65.         mTrayIcon.hIcon = m_Icon.Handle
  66.     End If
  67.     mTrayIcon.szTip = Trim$(m_ToolTipText) & vbNullChar
  68.     Shell_NotifyIcon NIM_ADD, mTrayIcon
  69. Exit Sub
  70. ErrorTrap:
  71.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  72.        Err.Description & vbNewLine & _
  73.        vbNewLine & _
  74.        "Debug Information:" & vbNewLine & _
  75.        "MidiDateBase.SysTrayIcon.AddSystemTray" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  76. End Sub
  77. Public Property Get Icon() As Picture
  78.     On Error GoTo ErrorTrap
  79.     Set Icon = m_Icon
  80. Exit Property
  81. ErrorTrap:
  82.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  83.        Err.Description & vbNewLine & _
  84.        vbNewLine & _
  85.        "Debug Information:" & vbNewLine & _
  86.        "MidiDateBase.SysTrayIcon.Icon" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  87. End Property
  88. Public Property Set Icon(vNewValue As Picture)
  89.     On Error GoTo ErrorTrap
  90.     If PictureType(vNewValue) = vbPicTypeIcon Then
  91.         Set m_Icon = vNewValue
  92.         PropertyChanged "Icon"
  93.         ModSystemTray
  94.         Set UserControl.Picture = vNewValue
  95.     ElseIf (PictureType(vNewValue) = vbPicTypeNone) Then
  96.         Set m_Icon = LoadPicture("")
  97.         Set UserControl.Picture = m_Icon
  98.         PropertyChanged "Icon"
  99.         RemoveSystemTray
  100.     Else
  101.         MsgBox "Only Icons and Cursors allowed.", vbInformation, UserControl.Ambient.DisplayName
  102.     End If
  103. Exit Property
  104. ErrorTrap:
  105.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  106.        Err.Description & vbNewLine & _
  107.        vbNewLine & _
  108.        "Debug Information:" & vbNewLine & _
  109.        "MidiDateBase.SysTrayIcon.Icon" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  110. End Property
  111. Public Property Get IconToolTipText() As String
  112.     On Error GoTo ErrorTrap
  113.     IconToolTipText = Trim$(m_ToolTipText)
  114. Exit Property
  115. ErrorTrap:
  116.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  117.        Err.Description & vbNewLine & _
  118.        vbNewLine & _
  119.        "Debug Information:" & vbNewLine & _
  120.        "MidiDateBase.SysTrayIcon.IconToolTipText" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  121. End Property
  122. Public Property Let IconToolTipText(ByVal vNewValue As String)
  123.     On Error GoTo ErrorTrap
  124.     m_ToolTipText = Trim$(vNewValue)
  125.     PropertyChanged "IconToolTipText"
  126.     ModSystemTray
  127. Exit Property
  128. ErrorTrap:
  129.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  130.        Err.Description & vbNewLine & _
  131.        vbNewLine & _
  132.        "Debug Information:" & vbNewLine & _
  133.        "MidiDateBase.SysTrayIcon.IconToolTipText" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  134. End Property
  135. Public Property Get IconVisible() As Boolean
  136.     On Error GoTo ErrorTrap
  137.     IconVisible = m_Visible
  138. Exit Property
  139. ErrorTrap:
  140.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  141.        Err.Description & vbNewLine & _
  142.        vbNewLine & _
  143.        "Debug Information:" & vbNewLine & _
  144.        "MidiDateBase.SysTrayIcon.IconVisible" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  145. End Property
  146. Public Property Let IconVisible(ByVal vNewValue As Boolean)
  147.     On Error GoTo ErrorTrap
  148.     m_Visible = vNewValue
  149.     PropertyChanged "IconVisible"
  150.     If IsRunTime() = True Then   'Make the Icon visible only in runtime
  151.         If m_Visible Then
  152.             AddSystemTray
  153.         Else
  154.             RemoveSystemTray
  155.         End If
  156.     End If
  157. Exit Property
  158. ErrorTrap:
  159.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  160.        Err.Description & vbNewLine & _
  161.        vbNewLine & _
  162.        "Debug Information:" & vbNewLine & _
  163.        "MidiDateBase.SysTrayIcon.IconVisible" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  164. End Property
  165. Private Function IsRunTime() As Boolean
  166.     On Error GoTo ErrorTrap
  167.     IsRunTime = UserControl.Ambient.UserMode
  168. Exit Function
  169. ErrorTrap:
  170.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  171.        Err.Description & vbNewLine & _
  172.        vbNewLine & _
  173.        "Debug Information:" & vbNewLine & _
  174.        "MidiDateBase.SysTrayIcon.IsRunTime" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  175. End Function
  176. Private Sub ModSystemTray() ' Modify the Icon in the Tray
  177.     On Error GoTo ErrorTrap
  178.     With mTrayIcon
  179.         .cbSize = Len(mTrayIcon)
  180.         .hwnd = UserControl.hwnd
  181.         .uId = vbNull '1&
  182.         .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
  183.         .ucallbackMessage = WM_MOUSEMOVE
  184.     End With 'mTrayIcon
  185.     If PictureType(m_Icon) = vbPicTypeIcon Then
  186.         mTrayIcon.hIcon = m_Icon.Handle
  187.     End If
  188.     mTrayIcon.szTip = Trim$(m_ToolTipText) & vbNullChar
  189.     Shell_NotifyIcon NIM_MODIFY, mTrayIcon
  190. Exit Sub
  191. ErrorTrap:
  192.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  193.        Err.Description & vbNewLine & _
  194.        vbNewLine & _
  195.        "Debug Information:" & vbNewLine & _
  196.        "MidiDateBase.SysTrayIcon.ModSystemTray" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  197. End Sub
  198. Private Function PictureType(p As StdPicture) As PictureTypeConstants
  199. Dim ans As PictureTypeConstants
  200.     On Error GoTo ErrorTrap
  201.     If TypeName(p) = "Nothing" Then
  202.         ans = vbPicTypeNone
  203.     Else
  204.         ans = p.type
  205.     End If
  206.     PictureType = ans
  207. Exit Function
  208. ErrorTrap:
  209.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  210.        Err.Description & vbNewLine & _
  211.        vbNewLine & _
  212.        "Debug Information:" & vbNewLine & _
  213.        "MidiDateBase.SysTrayIcon.PictureType" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  214. End Function
  215. Private Sub RemoveSystemTray() ' Remove the Icon in the Tray
  216.     On Error GoTo ErrorTrap
  217.     With mTrayIcon
  218.         .cbSize = Len(mTrayIcon)
  219.         .hwnd = UserControl.hwnd
  220.         .uId = vbNull '1&
  221.     End With 'mTrayIcon
  222.     Shell_NotifyIcon NIM_DELETE, mTrayIcon
  223. Exit Sub
  224. ErrorTrap:
  225.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  226.        Err.Description & vbNewLine & _
  227.        vbNewLine & _
  228.        "Debug Information:" & vbNewLine & _
  229.        "MidiDateBase.SysTrayIcon.RemoveSystemTray" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  230. End Sub
  231. Private Sub UserControl_MouseMove(Button As Integer, _
  232.                                   Shift As Integer, _
  233.                                   x As Single, _
  234.                                   y As Single)
  235.     On Error GoTo ErrorTrap
  236. 'Raise the Respective events after analysis of X.
  237.     Select Case x \ Screen.TwipsPerPixelX
  238.     Case WM_MOUSEMOVE
  239.         RaiseEvent MouseMoved
  240.     Case WM_LBUTTONDOWN
  241.         RaiseEvent LeftButtonDown
  242.     Case WM_LBUTTONUP
  243.         RaiseEvent LeftButtonUp
  244.     Case WM_LBUTTONDBLCLK
  245.         RaiseEvent LeftButtonDoubleClick
  246.     Case WM_RBUTTONDOWN
  247.         RaiseEvent RightButtonDown
  248.     Case WM_RBUTTONUP
  249.         RaiseEvent RightButtonUp
  250.     Case WM_RBUTTONDBLCLK
  251.         RaiseEvent RightButtonDoubleClick
  252.     End Select
  253. Exit Sub
  254. ErrorTrap:
  255.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  256.        Err.Description & vbNewLine & _
  257.        vbNewLine & _
  258.        "Debug Information:" & vbNewLine & _
  259.        "MidiDateBase.SysTrayIcon.UserControl_MouseMove" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  260. End Sub
  261. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  262.     On Error GoTo ErrorTrap
  263.     With PropBag
  264.         Set m_Icon = .ReadProperty("Icon", Nothing)
  265.         m_ToolTipText = Trim$(.ReadProperty("IconToolTipText", " "))
  266.         m_Visible = .ReadProperty("IconVisible", False)
  267.     End With 'PropBag
  268.     If IsRunTime() = True Then   'Make the Icon visible only in runtime
  269.         If m_Visible Then
  270.             AddSystemTray
  271.         Else
  272.             RemoveSystemTray
  273.         End If
  274.     End If
  275.     Set UserControl.Picture = m_Icon
  276. Exit Sub
  277. ErrorTrap:
  278.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  279.        Err.Description & vbNewLine & _
  280.        vbNewLine & _
  281.        "Debug Information:" & vbNewLine & _
  282.        "MidiDateBase.SysTrayIcon.UserControl_ReadProperties" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  283. End Sub
  284. Private Sub UserControl_Terminate()
  285.     On Error GoTo ErrorTrap
  286.     RemoveSystemTray
  287. Exit Sub
  288. ErrorTrap:
  289.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  290.        Err.Description & vbNewLine & _
  291.        vbNewLine & _
  292.        "Debug Information:" & vbNewLine & _
  293.        "MidiDateBase.SysTrayIcon.UserControl_Terminate" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  294. End Sub
  295. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  296.     On Error GoTo ErrorTrap
  297.     With PropBag
  298.         .WriteProperty "Icon", m_Icon, Nothing
  299.         .WriteProperty "IconToolTipText", Trim$(m_ToolTipText), " "
  300.         .WriteProperty "IconVisible", m_Visible, False
  301.     End With 'PropBag
  302. Exit Sub
  303. ErrorTrap:
  304.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  305.        Err.Description & vbNewLine & _
  306.        vbNewLine & _
  307.        "Debug Information:" & vbNewLine & _
  308.        "MidiDateBase.SysTrayIcon.UserControl_WriteProperties" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  309. End Sub
  310. ':)Code Fixer V3.0.9 (9/15/2005 1:30:33 PM) 36 + 273 = 309 Lines Thanks Ulli for inspiration and lots of code.
  311.  
  312.  
  313.