高手请进，找到部分创建托盘条代码！须完善，内详！

modTray.bas
====================Option Explicit
' All the code has been based on:
'
'           Softworld tm磗 * Softshell Logi Beta 1.3 *
'           abd Mattias Sj鰃ren's code (SysTray).
'           this version: (c)2000 Roeland Kluit
'
Private Declare Function DrawIconEx Lib "user32" (ByVal HDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Integer) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)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 TypePrivate Type COPYDATASTRUCT
  dwData As Long
  cbData As Long
  lpData As Long
End TypePrivate Type WNDCLASSEX
  cbSize As Long
  Style As Long
  lpfnWndProc As Long
  cbClsExtra As Long
  cbWndExtra As Long
  hInstance As Long
  hIcon As Long
  hCursor As Long
  hbrBackground As Long
  lpszMenuName As String
  lpszClassName As String
  hIconSm As Long
End TypePrivate Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const WM_GETICON = &H7F
Private Const WM_QUERYDRAGICON = &H37
Private Const WM_COPYDATA = &H4A
Private Const WS_POPUP = &H80000000
Private Const WS_EX_TOPMOST = &H8&
Private Const HWND_BROADCAST = &HFFFF&
Private Const DI_NORMAL = &H3
Private Const GCL_HICON = (-14)
Private Const GCL_HICONSM = (-34)
Private Const WC_SYSTRAY As String = "Shell_TrayWnd"Private Pwidth As Long
Private stBool As Boolean
Private m_hTaskBarCreated As Long
Private m_hSysTray As Long
Private sObjLeft As Long
Private IconIndex As Integer
Private lastIndex As IntegerPublic m_colTrayIcons As CollectionPublic Sub LoadTrayIconHandler()
Dim wcx As WNDCLASSEX
  Dim lRet As Long

  IconIndex = 1
  stBool = False
  m_hTaskBarCreated = RegisterWindowMessage("TaskbarCreated")

  With wcx
    .cbSize = Len(wcx)
    .lpfnWndProc = FuncPtr(AddressOf WindowProc)
    .hInstance = App.hInstance
    .lpszClassName = WC_SYSTRAY
  End With

  Call RegisterClassEx(wcx)

  m_hSysTray = CreateWindowEx(WS_EX_TOPMOST, WC_SYSTRAY, vbNullString, WS_POPUP, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)  Set m_colTrayIcons = New Collection

    For lRet = 1 To m_colTrayIcons.Count
      m_colTrayIcons.Remove 1
    Next

    Call SendMessage(HWND_BROADCAST, m_hTaskBarCreated, 0&, ByVal 0&)

End SubPublic Sub UnLoadTrayIconHandler()  ' destroy systray window ...
  Call DestroyWindow(m_hSysTray)

  ' ... and unregister the window class
  Call UnregisterClass(WC_SYSTRAY, App.hInstance)

  ' free icon collection
  Set m_colTrayIcons = NothingEnd SubPublic Function GetIcon(hwnd As Long) As Long
    Call SendMessageTimeout(hwnd, WM_GETICON, 0, 0, 0, 1000, GetIcon)
    If Not CBool(GetIcon) Then GetIcon = GetClassLong(hwnd, GCL_HICONSM)
    If Not CBool(GetIcon) Then Call SendMessageTimeout(hwnd, WM_GETICON, 1, 0, 0, 1000, GetIcon)
    If Not CBool(GetIcon) Then GetIcon = GetClassLong(hwnd, GCL_HICON)
    If Not CBool(GetIcon) Then Call SendMessageTimeout(hwnd, WM_QUERYDRAGICON, 0, 0, 0, 1000, GetIcon)
End FunctionPublic Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long  Static cds As COPYDATASTRUCT
  If uMsg = WM_COPYDATA Then
    MoveMemory cds, ByVal lParam, Len(cds)
    If cds.dwData = 1 Then  ' this is probably a tray message
      WindowProc = TrayIconHandler(cds.lpData)
      Exit Function
    End If
  End If

  WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)

End Function' AddressOf wrapper
Private Function FuncPtr(ByVal pfn As Long) As Long
  FuncPtr = pfn
End Function

Private Function TrayIconHandler(ByVal lpIconData As Long) As Long

  Dim nid As NOTIFYICONDATA
  Dim ti As clsTrayIcon
  Dim dwMessage As Long
  Dim sKey As String

  ' The NIM_ message starts 4 bytes after lpIconData
  MoveMemory dwMessage, ByVal lpIconData + 4, Len(dwMessage)
  ' The NOTIFYICONDATA struct starts 8 bytes after lpIconData
  MoveMemory nid, ByVal lpIconData + 8, Len(nid)  sKey = KeyFromIcon(nid.hwnd, nid.uID)

  On Error Resume Next
  Dim Ol As Long
  Select Case dwMessage
    Case NIM_ADD

      Set ti = New clsTrayIcon
      ti.ModifyFromNID lpIconData + 8
      m_colTrayIcons.Add ti, sKey

      With ti
        '//--Softworld Code 2000-08-12
            If stBool = False Then sObjLeft = frmTray.imgTrayIcon(IconIndex - 1).Left + frmTray.imgTrayIcon(IconIndex - 1).Width + 40
            stBool = False
            Load frmTray.imgTrayIcon(IconIndex)

            frmTray.imgTrayIcon(IconIndex).Picture = .VBIcon
            frmTray.imgTrayIcon(IconIndex).Top = 40
            frmTray.imgTrayIcon(IconIndex).Left = sObjLeft
            frmTray.imgTrayIcon(IconIndex).Width = frmTray.imgTrayIcon(0).Width
            frmTray.imgTrayIcon(IconIndex).Height = frmTray.imgTrayIcon(0).Height
            frmTray.imgTrayIcon(IconIndex).Visible = True
            frmTray.imgTrayIcon(IconIndex).Tag = sKey
            frmTray.imgTrayIcon(IconIndex).ToolTipText = .ToolTipText
            IconIndex = IconIndex + 1
        '//--
      End With

    Case NIM_MODIFY

      Set ti = m_colTrayIcons(sKey)

      With ti
        .ModifyFromNID lpIconData + 8
        '//--Softworld Code

      For Ol = 1 To frmTray.imgTrayIcon.Count - 1
        If frmTray.imgTrayIcon(Ol).Tag = sKey Then
            frmTray.imgTrayIcon(Ol).Picture = .VBIcon
            Exit For
        End If
      Next Ol

      '//--
      End With

    Case NIM_DELETE

      m_colTrayIcons.Remove sKey
      '//--Softworld Code

      For Ol = 1 To frmTray.imgTrayIcon.Count - 1
        If frmTray.imgTrayIcon(Ol).Tag = sKey Then
            frmTray.imgTrayIcon(Ol).Tag = "skip"

            frmTray.imgTrayIcon(Ol).Visible = False
            Call FixTrayIcons

        Exit For
        End If
      Next Ol

      '//--
  End Select

  Set ti = Nothing  TrayIconHandler = 1End FunctionPrivate Function KeyFromIcon(ByVal hOwner As Long, ByVal ID As Long) As String
  KeyFromIcon = "K" & Hex$(hOwner) & "-" & Trim$(Str$(ID))
End FunctionPrivate Sub FixTrayIcons()
'//--Softworld Code
Dim Lo As Long
Dim Asa As Long
For Lo = 1 To frmTray.imgTrayIcon.Count - 1
    If frmTray.imgTrayIcon(Lo).Tag <> "skip" Then

        frmTray.imgTrayIcon(Lo).Left = 40 + Asa
        Asa = Asa + frmTray.imgTrayIcon(0).Width + 40
    End If
Next Lo
For Lo = frmTray.imgTrayIcon.Count - 1 To 1 Step -1
    If frmTray.imgTrayIcon(Lo).Tag <> "skip" Then
        sObjLeft = frmTray.imgTrayIcon(Lo).Left + frmTray.imgTrayIcon(Lo).Width + 40
    Exit For
    End If
Next Lo
stBool = True
End SubPrivate Sub DrawIcon(HDC As Long, hwnd As Long, X As Integer, Y As Integer)
    Dim ico As Long
    ico = GetIcon(hwnd)
    DrawIconEx HDC, X, Y, ico, 16, 16, 0, 0, DI_NORMAL
End SubPrivate Sub UpdateButtonIcon(Index As Long, Sort As Integer)
    DrawIcon frmTray.picIcon(Sort).HDC, Index, 1, 1
End Sub
Public Function freeTrayObjects()
    Dim ti As clsTrayIcon
    On Error Resume Next
    Set ti = m_colTrayIcons(frmTray.imgTrayIcon(lastIndex).Tag)
    If Err = 0 Then
        frmTray.SetFocus
        ti.PostCallbackMessage WM_MOUSEMOVE
        lastIndex = -1
    End If
End FunctionPublic Function trayClick(ByVal msg As TrayIconMouseMessages, ByVal Index As Integer) As Boolean
    Dim ti As clsTrayIcon
    Dim lRet As Long

    Set ti = m_colTrayIcons(frmTray.imgTrayIcon(Index).Tag)

    If Err.Number = 0 Then
        ti.PostCallbackMessage msg
        trayClick = True
        lastIndex = Index
    Else
        Err.Clear
    End If
    Set ti = NothingEnd Function

clsTrayicon.cls
=======================
Option Explicit
'//--Thank磗 to Mattias Sj鰃ren who is the orginal writer of this SysTray      --//
'//--I have made some changes to it so it will fit to my app                   --//Public Enum TrayIconMouseMessages
  WM_MOUSEMOVE = &H200
  WM_LBUTTONDOWN = &H201
  WM_LBUTTONUP = &H202
  WM_LBUTTONDBLCLK = &H203
  WM_RBUTTONDOWN = &H204
  WM_RBUTTONUP = &H205
  WM_RBUTTONDBLCLK = &H206
  WM_MBUTTONDOWN = &H207
  WM_MBUTTONUP = &H208
  WM_MBUTTONDBLCLK = &H209
End Enum' NOTIFYICONDATA flags
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2Public Enum InfoTipFlags
  NIIF_NONE = &H0
  NIIF_INFO = &H1
  NIIF_WARNING = &H2
  NIIF_ERROR = &H3
End Enum' OSVERSIONINFO platform flag
Private Const VER_PLATFORM_WIN32_NT = 2'''''''''''''''''
'''   Types   '''
'''''''''''''''''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' extended NOTIFYICONDATA - Implemented in shell32.dll >= v5.0 (Win2000)
Private Type NOTIFYICONDATA_5
  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
  uTimeout As Long
  szInfoTitle As String * 64
  dwInfoFlags As Long
End TypePrivate Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformID As Long
  szCSDVersion(127) As Byte
End TypePrivate Type PICTDESC_ICON  ' PICTDESC for PICTYPE_ICON
  cbSizeofStruct As Long
  picType As Long
  hIcon As Long
  padding1 As Long
  padding2 As Long
End TypePrivate Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
''''''''''''''''''''
'''   Declares   '''
''''''''''''''''''''Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As LongPrivate Declare Function OleCreateIconIndirect Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (pPictDesc As PICTDESC_ICON, riid As GUID, ByVal fOwn As Long, ppvObj As IPicture) As LongPrivate Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'''''''''''''''''''''
'''   Variables   '''
'''''''''''''''''''''Private m_hOwner As Long
Private m_lID As Long
Private m_sToolTip As String
Private m_hIcon As Long
Private m_lMsg As Long
Private m_dtCreated As Date
Private m_dtModified As Date
Private m_picIcon As Picture
Private m_fSharedIcon As Boolean
Private m_fHidden As Boolean
Private m_sInfoTip As String
Private m_sInfoTitle As String
Private m_lInfoTimeout As Long
Private m_itfInfoIcon As InfoTipFlagsPrivate m_fIsUnicodeSystem As Boolean
Private m_fIsWindows2000 As BooleanPublic Sub ModifyFromNID(ByVal pNID As Long)  Dim nid As NOTIFYICONDATA
  Dim nid5 As NOTIFYICONDATA_5
  Dim fIsNid5Struct As Boolean

  ' On Unicode systems (WinNT4 and Win2000), pNID will point to a
  ' NOTIFYICONDATAW struct, even if the calling app uses
  ' Shell_NotifyIconA. On Win9x, it's a pointer to a
  ' NOTIFYICONDATAA struct.
  If m_fIsUnicodeSystem Then
    MoveMemory ByVal VarPtr(nid), ByVal pNID, LenB(nid)
    If m_fIsWindows2000 And (nid.cbSize >= LenB(nid5)) Then
      MoveMemory ByVal VarPtr(nid5), ByVal pNID, LenB(nid5)
      fIsNid5Struct = True
    End If
  Else
    MoveMemory nid, ByVal pNID, Len(nid)
  End If

  If m_hOwner = 0 Then
    m_hOwner = nid.hwnd
    m_lID = nid.uID
  End If  ' Update the modified properties
  If nid.uFlags And NIF_MESSAGE Then m_lMsg = nid.uCallbackMessage
  If nid.uFlags And NIF_ICON Then
    m_hIcon = nid.hIcon
    Set m_picIcon = PictureFromhIcon(m_hIcon)
  End If

  If fIsNid5Struct Then
    If nid5.uFlags And NIF_TIP Then m_sToolTip = nid5.szTip
    If nid5.uFlags And NIF_STATE Then
      If nid5.dwStateMask And NIS_HIDDEN Then m_fHidden = CBool(nid5.dwState And NIS_HIDDEN)
      If nid5.dwStateMask And NIS_SHAREDICON Then m_fSharedIcon = CBool(nid5.dwState And NIS_SHAREDICON)
    End If
    If nid5.uFlags And NIF_INFO Then
      m_itfInfoIcon = nid5.dwInfoFlags
      m_sInfoTip = nid5.szInfo
      m_sInfoTitle = nid5.szInfoTitle
      m_lInfoTimeout = nid5.uTimeout

    End If
  Else
    If nid.uFlags And NIF_TIP Then m_sToolTip = nid.szTip
  End If

  ' Update modified date
  m_dtModified = Now

End SubPublic Property Get ToolTipText() As String
  ToolTipText = m_sToolTip
End PropertyPublic Property Get hIcon() As Long
  hIcon = m_hIcon
End PropertyPublic Property Get VBIcon() As IPictureDisp
  Set VBIcon = m_picIcon
End PropertyPublic Property Get CallbackMessage() As Long
  CallbackMessage = m_lMsg
End PropertyPublic Property Get OwnerWindow() As Long
  OwnerWindow = m_hOwner
End PropertyPublic Property Get ID() As Long
  ID = m_lID
End PropertyPublic Property Get Hidden() As Boolean
  Hidden = m_fHidden
End PropertyPublic Property Get SharedIcon() As Boolean
  SharedIcon = m_fSharedIcon
End PropertyPublic Property Get InfoTip() As String
  InfoTip = m_sInfoTip
End PropertyPublic Property Get InfoTitle() As String
  InfoTitle = m_sInfoTitle
End PropertyPublic Property Get InfoTipIcon() As InfoTipFlags
  InfoTipIcon = m_itfInfoIcon
End PropertyPublic Property Get InfoTimeout() As String
  InfoTimeout = m_lInfoTimeout
End PropertyPublic Property Get CreatedDate() As Date
  CreatedDate = m_dtCreated
End PropertyPublic Property Get ModifiedDate() As Date
  ModifiedDate = m_dtModified
End PropertyPublic Sub PostCallbackMessage(ByVal Message As TrayIconMouseMessages)  ' Post message to the message queue of the owner window
  ' wParam = Icon ID
  ' lParam = Mouse message (WM_xBUTTONyyyyy)
  Call PostMessage(m_hOwner, m_lMsg, m_lID, Message)

End Sub' Creates a VB friedly Picture object from a GDI icon object handle
Private Function PictureFromhIcon(ByVal hIcon As Long) As IPicture  Dim oIcon As Picture
  Dim pdi As PICTDESC_ICON
  Dim IID_IPicture As GUID


  If hIcon = 0 Then Exit Function  With pdi
    .cbSizeofStruct = Len(pdi)
    .picType = vbPicTypeIcon    ' PICTYPE_ICON
    .hIcon = hIcon
  End With

  ' IID_IPicture = {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  With IID_IPicture
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4(0) = &H8B
    .Data4(1) = &HBB
    .Data4(2) = &H0
    .Data4(3) = &HAA
    .Data4(4) = &H0
    .Data4(5) = &H30
    .Data4(6) = &HC
    .Data4(7) = &HAB
  End With

  Call OleCreateIconIndirect(pdi, IID_IPicture, 0&, oIcon)  Set PictureFromhIcon = oIconEnd FunctionPrivate Sub Class_Initialize()  Dim ovi As OSVERSIONINFO


  ' check if we are running NT
  ovi.dwOSVersionInfoSize = Len(ovi)
  Call GetVersionEx(ovi)
  m_fIsUnicodeSystem = CBool(ovi.dwPlatformID And VER_PLATFORM_WIN32_NT)

  If m_fIsUnicodeSystem And (ovi.dwMajorVersion >= 5) Then m_fIsWindows2000 = True

  m_dtCreated = Now
  m_dtModified = Now

  m_sInfoTip = "N/A"
  m_sInfoTitle = "N/A"

End Sub

http://www.csdn.net/cnshare/soft/16/16015.shtm

呵呵，楼上这位兄弟真是够粗心的，联结的代码虽然很精彩，但不是本贴的内容
这段代码没有问题，唯一的不足是点击后出来的音量面版会落到任务条下面（任务条是我自己作的，系统任务条隐藏了）。那位朋友要是能改进这个问题那就谢谢了！
VERSION 5.00
Begin VB.Form frmTray
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "Windows Sytem Tray"
   ClientHeight    =   1665
   ClientLeft      =   150
   ClientTop       =   390
   ClientWidth     =   5610
   Icon            =   "frmTray.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1665
   ScaleWidth      =   5610
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox picTray
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   450
      Left            =   180
      Picture         =   "frmTray.frx":0442
      ScaleHeight     =   28
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   257
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   210
      Width           =   3885
      Begin VB.Timer tmrSysTray
         Interval        =   50
         Left            =   1680
         Top             =   -15
      End
      Begin VB.PictureBox picIcon
         BorderStyle     =   0  'None
         Height          =   375
         Index           =   0
         Left            =   1200
         ScaleHeight     =   375
         ScaleWidth      =   375
         TabIndex        =   1
         TabStop         =   0   'False
         Top             =   0
         Visible         =   0   'False
         Width           =   375
      End
      Begin VB.Image imgTrayIcon
         Height          =   330
         Index           =   0
         Left            =   -330
         Stretch         =   -1  'True
         Top             =   -50
         Width           =   330
      End
   End
End
Attribute VB_Name = "frmTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option ExplicitPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
freeTrayObjects
End SubPrivate Sub lblTray_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Form_MouseDown Button, Shift, X, Y
End SubPrivate Sub tmrSysTray_Timer()
'Update Tray
Dim iconCount As Long, dtrLeft As Long    For iconCount = 1 To imgTrayIcon.Count - 1
        If imgTrayIcon(iconCount).Tag <> "skip" Then dtrLeft = dtrLeft + (IconWidth + 3) * 15 '+ 3 * 15
    Next iconCountpicTray.Width = dtrLeft + 7 * 15End SubPrivate Sub imgTrayicon_DblClick(Index As Integer)
    'SysTrayMouseDoubleClick
    trayClick WM_LBUTTONDBLCLK, Index
End SubPrivate Sub imgTrayicon_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    'SysTrayMouseMove
    trayClick WM_MOUSEMOVE, Index
End SubPrivate Sub imgTrayicon_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    'SysTrayMouseDown
    trayClick IIf(Button = 1, WM_LBUTTONDOWN, WM_RBUTTONDOWN), Index
End SubPrivate Sub imgTrayicon_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    'SysTrayMouseUp
    trayClick IIf(Button = 1, WM_LBUTTONUP, WM_RBUTTONUP), Index
End SubPublic Sub Form_load()
    imgTrayIcon(0).Left = 0 - IconWidth
    'Load Tray
    Call LoadTrayIconHandler
End SubPrivate Sub Form_Unload(Cancel As Integer)
    'unLoad Tray
    Call UnLoadTrayIconHandler
End Sub

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsTrayIcon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'//--Thank磗 to Mattias Sj鰃ren who is the orginal writer of this SysTray      --//
'//--I have made some changes to it so it will fit to my app                   --//Public Enum TrayIconMouseMessages
  WM_MOUSEMOVE = &H200
  WM_LBUTTONDOWN = &H201
  WM_LBUTTONUP = &H202
  WM_LBUTTONDBLCLK = &H203
  WM_RBUTTONDOWN = &H204
  WM_RBUTTONUP = &H205
  WM_RBUTTONDBLCLK = &H206
  WM_MBUTTONDOWN = &H207
  WM_MBUTTONUP = &H208
  WM_MBUTTONDBLCLK = &H209
End Enum' NOTIFYICONDATA flags
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2Public Enum InfoTipFlags
  NIIF_NONE = &H0
  NIIF_INFO = &H1
  NIIF_WARNING = &H2
  NIIF_ERROR = &H3
End Enum' OSVERSIONINFO platform flag
Private Const VER_PLATFORM_WIN32_NT = 2'''''''''''''''''
'''   Types   '''
'''''''''''''''''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' extended NOTIFYICONDATA - Implemented in shell32.dll >= v5.0 (Win2000)
Private Type NOTIFYICONDATA_5
  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
  uTimeout As Long
  szInfoTitle As String * 64
  dwInfoFlags As Long
End TypePrivate Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformID As Long
  szCSDVersion(127) As Byte
End TypePrivate Type PICTDESC_ICON  ' PICTDESC for PICTYPE_ICON
  cbSizeofStruct As Long
  picType As Long
  hIcon As Long
  padding1 As Long
  padding2 As Long
End TypePrivate Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
''''''''''''''''''''
'''   Declares   '''
''''''''''''''''''''Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As LongPrivate Declare Function OleCreateIconIndirect Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (pPictDesc As PICTDESC_ICON, riid As GUID, ByVal fOwn As Long, ppvObj As IPicture) As LongPrivate Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'''''''''''''''''''''
'''   Variables   '''
'''''''''''''''''''''Private m_hOwner As Long
Private m_lID As Long
Private m_sToolTip As String
Private m_hIcon As Long
Private m_lMsg As Long
Private m_dtCreated As Date
Private m_dtModified As Date
Private m_picIcon As Picture
Private m_fSharedIcon As Boolean
Private m_fHidden As Boolean
Private m_sInfoTip As String
Private m_sInfoTitle As String
Private m_lInfoTimeout As Long
Private m_itfInfoIcon As InfoTipFlagsPrivate m_fIsUnicodeSystem As Boolean
Private m_fIsWindows2000 As BooleanPublic Sub ModifyFromNID(ByVal pNID As Long)  Dim nid As NOTIFYICONDATA

Dim nid5 As NOTIFYICONDATA_5
  Dim fIsNid5Struct As Boolean

  ' On Unicode systems (WinNT4 and Win2000), pNID will point to a
  ' NOTIFYICONDATAW struct, even if the calling app uses
  ' Shell_NotifyIconA. On Win9x, it's a pointer to a
  ' NOTIFYICONDATAA struct.
  If m_fIsUnicodeSystem Then
    MoveMemory ByVal VarPtr(nid), ByVal pNID, LenB(nid)
    If m_fIsWindows2000 And (nid.cbSize >= LenB(nid5)) Then
      MoveMemory ByVal VarPtr(nid5), ByVal pNID, LenB(nid5)
      fIsNid5Struct = True
    End If
  Else
    MoveMemory nid, ByVal pNID, Len(nid)
  End If

  If m_hOwner = 0 Then
    m_hOwner = nid.hwnd
    m_lID = nid.uID
  End If  ' Update the modified properties
  If nid.uFlags And NIF_MESSAGE Then m_lMsg = nid.uCallbackMessage
  If nid.uFlags And NIF_ICON Then
    m_hIcon = nid.hIcon
    Set m_picIcon = PictureFromhIcon(m_hIcon)
  End If

  If fIsNid5Struct Then
    If nid5.uFlags And NIF_TIP Then m_sToolTip = nid5.szTip
    If nid5.uFlags And NIF_STATE Then
      If nid5.dwStateMask And NIS_HIDDEN Then m_fHidden = CBool(nid5.dwState And NIS_HIDDEN)
      If nid5.dwStateMask And NIS_SHAREDICON Then m_fSharedIcon = CBool(nid5.dwState And NIS_SHAREDICON)
    End If
    If nid5.uFlags And NIF_INFO Then
      m_itfInfoIcon = nid5.dwInfoFlags
      m_sInfoTip = nid5.szInfo
      m_sInfoTitle = nid5.szInfoTitle
      m_lInfoTimeout = nid5.uTimeout

    End If
  Else
    If nid.uFlags And NIF_TIP Then m_sToolTip = nid.szTip
  End If

  ' Update modified date
  m_dtModified = Now

End SubPublic Property Get ToolTipText() As String
  ToolTipText = m_sToolTip
End PropertyPublic Property Get hIcon() As Long
  hIcon = m_hIcon
End PropertyPublic Property Get VBIcon() As IPictureDisp
  Set VBIcon = m_picIcon
End PropertyPublic Property Get CallbackMessage() As Long
  CallbackMessage = m_lMsg
End PropertyPublic Property Get OwnerWindow() As Long
  OwnerWindow = m_hOwner
End PropertyPublic Property Get ID() As Long
  ID = m_lID
End PropertyPublic Property Get Hidden() As Boolean
  Hidden = m_fHidden
End PropertyPublic Property Get SharedIcon() As Boolean
  SharedIcon = m_fSharedIcon
End PropertyPublic Property Get InfoTip() As String
  InfoTip = m_sInfoTip
End PropertyPublic Property Get InfoTitle() As String
  InfoTitle = m_sInfoTitle
End PropertyPublic Property Get InfoTipIcon() As InfoTipFlags
  InfoTipIcon = m_itfInfoIcon
End PropertyPublic Property Get InfoTimeout() As String
  InfoTimeout = m_lInfoTimeout
End PropertyPublic Property Get CreatedDate() As Date
  CreatedDate = m_dtCreated
End PropertyPublic Property Get ModifiedDate() As Date
  ModifiedDate = m_dtModified
End PropertyPublic Sub PostCallbackMessage(ByVal Message As TrayIconMouseMessages)  ' Post message to the message queue of the owner window
  ' wParam = Icon ID
  ' lParam = Mouse message (WM_xBUTTONyyyyy)
  Call PostMessage(m_hOwner, m_lMsg, m_lID, Message)

End Sub' Creates a VB friedly Picture object from a GDI icon object handle
Private Function PictureFromhIcon(ByVal hIcon As Long) As IPicture  Dim oIcon As Picture
  Dim pdi As PICTDESC_ICON
  Dim IID_IPicture As GUID


  If hIcon = 0 Then Exit Function  With pdi
    .cbSizeofStruct = Len(pdi)
    .picType = vbPicTypeIcon    ' PICTYPE_ICON
    .hIcon = hIcon
  End With

  ' IID_IPicture = {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  With IID_IPicture
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4(0) = &H8B
    .Data4(1) = &HBB
    .Data4(2) = &H0
    .Data4(3) = &HAA
    .Data4(4) = &H0
    .Data4(5) = &H30
    .Data4(6) = &HC
    .Data4(7) = &HAB
  End With

  Call OleCreateIconIndirect(pdi, IID_IPicture, 0&, oIcon)  Set PictureFromhIcon = oIconEnd FunctionPrivate Sub Class_Initialize()  Dim ovi As OSVERSIONINFO


  ' check if we are running NT
  ovi.dwOSVersionInfoSize = Len(ovi)
  Call GetVersionEx(ovi)
  m_fIsUnicodeSystem = CBool(ovi.dwPlatformID And VER_PLATFORM_WIN32_NT)

  If m_fIsUnicodeSystem And (ovi.dwMajorVersion >= 5) Then m_fIsWindows2000 = True

  m_dtCreated = Now
  m_dtModified = Now

  m_sInfoTip = "N/A"
  m_sInfoTitle = "N/A"

End Sub

Attribute VB_Name = "modTray"
Option Explicit
' All the code has been based on:
'
'           Softworld tm磗 * Softshell Logi Beta 1.3 *
'           abd Mattias Sj鰃ren's code (SysTray).
'           this version: (c)2000 Roeland Kluit
'
Private Declare Function DrawIconEx Lib "user32" (ByVal HDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Integer) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)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 TypePrivate Type COPYDATASTRUCT
  dwData As Long
  cbData As Long
  lpData As Long
End TypePrivate Type WNDCLASSEX
  cbSize As Long
  Style As Long
  lpfnWndProc As Long
  cbClsExtra As Long
  cbWndExtra As Long
  hInstance As Long
  hIcon As Long
  hCursor As Long
  hbrBackground As Long
  lpszMenuName As String
  lpszClassName As String
  hIconSm As Long
End TypePrivate Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const WM_GETICON = &H7F
Private Const WM_QUERYDRAGICON = &H37
Private Const WM_COPYDATA = &H4A
Private Const WS_POPUP = &H80000000
Private Const WS_EX_TOPMOST = &H8&
Private Const HWND_BROADCAST = &HFFFF&
Private Const DI_NORMAL = &H3
Private Const GCL_HICON = (-14)
Private Const GCL_HICONSM = (-34)
Private Const WC_SYSTRAY As String = "Shell_TrayWnd"Private Pwidth As Long
Private stBool As Boolean
Private m_hTaskBarCreated As Long
Private m_hSysTray As Long
Private sObjLeft As Long
Private IconIndex As Integer
Private lastIndex As Integer
Public Const IconWidth = 22Public m_colTrayIcons As CollectionPublic Sub LoadTrayIconHandler()
Dim wcx As WNDCLASSEX
  Dim lRet As Long

  IconIndex = 1
  stBool = False
  m_hTaskBarCreated = RegisterWindowMessage("TaskbarCreated")

  With wcx
    .cbSize = Len(wcx)
    .lpfnWndProc = FuncPtr(AddressOf WindowProc)
    .hInstance = App.hInstance
    .lpszClassName = WC_SYSTRAY
  End With

  Call RegisterClassEx(wcx)

  m_hSysTray = CreateWindowEx(WS_EX_TOPMOST, WC_SYSTRAY, vbNullString, WS_POPUP, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)  Set m_colTrayIcons = New Collection

    For lRet = 1 To m_colTrayIcons.Count
      m_colTrayIcons.Remove 1
    Next

    Call SendMessage(HWND_BROADCAST, m_hTaskBarCreated, 0&, ByVal 0&)

End SubPublic Sub UnLoadTrayIconHandler()  ' destroy systray window ...
  Call DestroyWindow(m_hSysTray)

  ' ... and unregister the window class
  Call UnregisterClass(WC_SYSTRAY, App.hInstance)

  ' free icon collection
  Set m_colTrayIcons = NothingEnd SubPublic Function GetIcon(hwnd As Long) As Long
    Call SendMessageTimeout(hwnd, WM_GETICON, 0, 0, 0, 1000, GetIcon)
    If Not CBool(GetIcon) Then GetIcon = GetClassLong(hwnd, GCL_HICONSM)
    If Not CBool(GetIcon) Then Call SendMessageTimeout(hwnd, WM_GETICON, 1, 0, 0, 1000, GetIcon)
    If Not CBool(GetIcon) Then GetIcon = GetClassLong(hwnd, GCL_HICON)
    If Not CBool(GetIcon) Then Call SendMessageTimeout(hwnd, WM_QUERYDRAGICON, 0, 0, 0, 1000, GetIcon)
End FunctionPublic Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long  Static cds As COPYDATASTRUCT
  If uMsg = WM_COPYDATA Then
    MoveMemory cds, ByVal lParam, Len(cds)
    If cds.dwData = 1 Then  ' this is probably a tray message
      WindowProc = TrayIconHandler(cds.lpData)
      Exit Function
    End If
  End If

  WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)

End Function' AddressOf wrapper
Private Function FuncPtr(ByVal pfn As Long) As Long
  FuncPtr = pfn
End FunctionPrivate Function TrayIconHandler(ByVal lpIconData As Long) As Long

  Dim nid As NOTIFYICONDATA
  Dim ti As clsTrayIcon

Dim dwMessage As Long
  Dim sKey As String

  ' The NIM_ message starts 4 bytes after lpIconData
  MoveMemory dwMessage, ByVal lpIconData + 4, Len(dwMessage)
  ' The NOTIFYICONDATA struct starts 8 bytes after lpIconData
  MoveMemory nid, ByVal lpIconData + 8, Len(nid)  sKey = KeyFromIcon(nid.hwnd, nid.uID)

  On Error Resume Next
  Dim Ol As Long
  Select Case dwMessage
    Case NIM_ADD

      Set ti = New clsTrayIcon
      ti.ModifyFromNID lpIconData + 8
      m_colTrayIcons.Add ti, sKey

      With ti
        '//--Softworld Code 2000-08-12
            If stBool = False Then sObjLeft = frmTray.imgTrayIcon(IconIndex - 1).Left + frmTray.imgTrayIcon(IconIndex - 1).Width + 3
            stBool = False
            Load frmTray.imgTrayIcon(IconIndex)

            frmTray.imgTrayIcon(IconIndex).Picture = .VBIcon
            frmTray.imgTrayIcon(IconIndex).Top = 3
            frmTray.imgTrayIcon(IconIndex).Left = sObjLeft
            frmTray.imgTrayIcon(IconIndex).Width = frmTray.imgTrayIcon(0).Width
            frmTray.imgTrayIcon(IconIndex).Height = frmTray.imgTrayIcon(0).Height
            frmTray.imgTrayIcon(IconIndex).Visible = True
            frmTray.imgTrayIcon(IconIndex).Tag = sKey
            frmTray.imgTrayIcon(IconIndex).ToolTipText = .ToolTipText
            IconIndex = IconIndex + 1
        '//--
      End With

    Case NIM_MODIFY

      Set ti = m_colTrayIcons(sKey)

      With ti
        .ModifyFromNID lpIconData + 8
        '//--Softworld Code

      For Ol = 1 To frmTray.imgTrayIcon.Count - 1
        If frmTray.imgTrayIcon(Ol).Tag = sKey Then
            frmTray.imgTrayIcon(Ol).Picture = .VBIcon
            Exit For
        End If
      Next Ol

      '//--
      End With

    Case NIM_DELETE

      m_colTrayIcons.Remove sKey
      '//--Softworld Code

      For Ol = 1 To frmTray.imgTrayIcon.Count - 1
        If frmTray.imgTrayIcon(Ol).Tag = sKey Then
            frmTray.imgTrayIcon(Ol).Tag = "skip"

            frmTray.imgTrayIcon(Ol).Visible = False
            Call FixTrayIcons

        Exit For
        End If
      Next Ol

      '//--
  End Select

  Set ti = Nothing  TrayIconHandler = 1End FunctionPrivate Function KeyFromIcon(ByVal hOwner As Long, ByVal ID As Long) As String
  KeyFromIcon = "K" & Hex$(hOwner) & "-" & Trim$(Str$(ID))
End FunctionPrivate Sub FixTrayIcons()
'//--Softworld Code
Dim Lo As Long
Dim Asa As Long
For Lo = 1 To frmTray.imgTrayIcon.Count - 1
    If frmTray.imgTrayIcon(Lo).Tag <> "skip" Then

        frmTray.imgTrayIcon(Lo).Left = 3 + Asa
        Asa = Asa + frmTray.imgTrayIcon(0).Width + 3
    End If
Next Lo
For Lo = frmTray.imgTrayIcon.Count - 1 To 1 Step -1
    If frmTray.imgTrayIcon(Lo).Tag <> "skip" Then
        sObjLeft = frmTray.imgTrayIcon(Lo).Left + frmTray.imgTrayIcon(Lo).Width + 3
    Exit For
    End If
Next Lo
stBool = True
End SubPrivate Sub DrawIcon(HDC As Long, hwnd As Long, X As Integer, Y As Integer)
    Dim ico As Long
    ico = GetIcon(hwnd)
    DrawIconEx HDC, X, Y, ico, 16, 16, 0, 0, DI_NORMAL
End SubPrivate Sub UpdateButtonIcon(Index As Long, Sort As Integer)
    DrawIcon frmTray.picIcon(Sort).HDC, Index, 1, 1
End Sub
Public Function freeTrayObjects()
    Dim ti As clsTrayIcon
    On Error Resume Next
    Set ti = m_colTrayIcons(frmTray.imgTrayIcon(lastIndex).Tag)
    If Err = 0 Then
        frmTray.SetFocus
        ti.PostCallbackMessage WM_MOUSEMOVE
        lastIndex = -1
    End If
End FunctionPublic Function trayClick(ByVal msg As TrayIconMouseMessages, ByVal Index As Integer) As Boolean
    Dim ti As clsTrayIcon
    Dim lRet As Long

    Set ti = m_colTrayIcons(frmTray.imgTrayIcon(Index).Tag)

    If Err.Number = 0 Then
        ti.PostCallbackMessage msg
        trayClick = True
        lastIndex = Index
    Else
        Err.Clear
    End If
    Set ti = NothingEnd Function

调试易

高手请进，找到部分创建托盘条代码！须完善，内详！

解决方案 »