タスクトレイにアイコンを表示するユーザーコントロール

２年くらいあっためてたレシピ。フォームにはっつけてIconプロパティに適当なアイコンを設定して、InTrayプロパティをTrueに設定すると、タスクトレイにアイコンが常駐します。アイコンがクリックされたりするとイベントが発生します。あと、コンテキストメニューも、FormなんかのPopUpMenuメソッドと同じ方法で表示することができます。ただし、自分で使う用に作ってあるので、無駄も多いしあんまり細かいところまでちゃんとできてません。バグもあるかもです。

これ作ったとき、VBでUserControlのPopupMenuメソッドでメニューを表示すると、キーボードでメニュー操作ができないのは何でかなー、フォーカスがはずれてもコンテキストメニューが出たままになってしまうなー、と問題を残したまま長く使っていたんだけど、このたび解決方法[homepage2.nifty.com]を見つけたので公開してみました。ポイントは

    Call SetForegroundWindow(UserControl.hwnd)
    Call UserControl.PopupMenu(Menu, flags, x, y, DefaultMenu)
    Call PostMessage(UserControl.hwnd, WM_NULL, 0&, 0&)

てな感じにSetForegroundWindowしてからメニューを表示しWM_NULLをポストすることらしいです。

---------------
2004/04/23 追記
GetSystemMetrics の引数を、間違って HEX で宣言していました。修正しました。
# うわーん、かっこわるー (-_-;)

注：まだ完全ではありません！

VERSION 5.00
Begin VB.UserControl ctlShellNotifyIcon 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  '実線
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.Image imgIcon 
      Height          =   1155
      Left            =   1500
      Top             =   1560
      Width           =   1185
   End
End
Attribute VB_Name = "ctlShellNotifyIcon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*===========================================================*
'* ctlShellNotifyIcon.ctl:タスクトレイアイコンコントロール   *
'*                                              by ba        *
'*===========================================================*
Option Explicit
Private Const CNST_MODULE_NAME      As String = "ctlShellNotifyIcon"

'======= イベント宣言 ========
'Public Event Click()
Public Event DblClick()
Public Event MouseDown(Button As Integer) ', Shift As Integer, X As Single, Y As Single)
Public Event MouseMove() 'Button As Integer) ', Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer) ', Shift As Integer, X As Single, Y As Single)

'======= プロパティの初期値 ========
Private Const mcblnPROP_INTRAY  As Boolean = False

'======= プロパティの内部変数 ========
Private mblnPropInTray          As Boolean

'======= W32 API関連 ========


Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As mENUM_NOTIFYICONMESSAGE, lpData As mtypNotifyIconData) As Long
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 Sub MoveMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private 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

Private Type mtypNotifyIconData
    cbSize              As Long
    hwnd                As Long
    uID                 As Long
    uFlags              As mENUM_NOTIFYICONFLAG
    uCallbackMessage    As Long
    hIcon               As Long
    szTip               As String * 64
End Type

Private Enum mENUM_NOTIFYICONMESSAGE
    NIM_ADD = &H0&
    NIM_MODIFY = &H1&
    NIM_DELETE = &H2&
End Enum

Private Enum mENUM_NOTIFYICONFLAG
    NIF_ICON = &H2&
    NIF_MESSAGE = &H1&
    NIF_TIP = &H4&
End Enum

Private Const DI_MASK           As Long = &H1&
Private Const DI_IMAGE          As Long = &H2&
Private Const DI_NORMAL         As Long = &H3&
Private Const DI_COMPAT         As Long = &H4&
Private Const DI_DEFAULTSIZE    As Long = &H8&

Private Const MK_LBUTTON        As Integer = &H1
Private Const MK_RBUTTON        As Integer = &H2
Private Const MK_SHIFT          As Integer = &H4
Private Const MK_CONTROL        As Integer = &H8
Private Const MK_MBUTTON        As Integer = &H10

Private Const WM_NULL           As Long = &H0&
Private Const WM_MOUSEFIRST     As Long = &H200
Private Const WM_MOUSEMOVE      As Long = &H200
Private Const WM_LBUTTONDOWN    As Long = &H201
Private Const WM_LBUTTONUP      As Long = &H202
Private Const WM_LBUTTONDBLCLK  As Long = &H203
Private Const WM_RBUTTONDOWN    As Long = &H204
Private Const WM_RBUTTONUP      As Long = &H205
Private Const WM_RBUTTONDBLCLK  As Long = &H206
Private Const WM_MBUTTONDOWN    As Long = &H207
Private Const WM_MBUTTONUP      As Long = &H208
Private Const WM_MBUTTONDBLCLK  As Long = &H209

'/*
' * GetSystemMetrics() codes
' */
Private Const SM_CXSCREEN             As Long = 0&
Private Const SM_CYSCREEN             As Long = 1&
Private Const SM_CXVSCROLL            As Long = 2&
Private Const SM_CYHSCROLL            As Long = 3&
Private Const SM_CYCAPTION            As Long = 4&
Private Const SM_CXBORDER             As Long = 5&
Private Const SM_CYBORDER             As Long = 6&
Private Const SM_CXDLGFRAME           As Long = 7&
Private Const SM_CYDLGFRAME           As Long = 8&
Private Const SM_CYVTHUMB             As Long = 9&
Private Const SM_CXHTHUMB             As Long = 10&
Private Const SM_CXICON               As Long = 11&
Private Const SM_CYICON               As Long = 12&
Private Const SM_CXCURSOR             As Long = 13&
Private Const SM_CYCURSOR             As Long = 14&
Private Const SM_CYMENU               As Long = 15&
Private Const SM_CXFULLSCREEN         As Long = 16&
Private Const SM_CYFULLSCREEN         As Long = 17&
Private Const SM_CYKANJIWINDOW        As Long = 18&
Private Const SM_MOUSEPRESENT         As Long = 19&
Private Const SM_CYVSCROLL            As Long = 20&
Private Const SM_CXHSCROLL            As Long = 21&
Private Const SM_DEBUG                As Long = 22&
Private Const SM_SWAPBUTTON           As Long = 23&
Private Const SM_RESERVED1            As Long = 24&
Private Const SM_RESERVED2            As Long = 25&
Private Const SM_RESERVED3            As Long = 26&
Private Const SM_RESERVED4            As Long = 27&
Private Const SM_CXMIN                As Long = 28&
Private Const SM_CYMIN                As Long = 29&
Private Const SM_CXSIZE               As Long = 30&
Private Const SM_CYSIZE               As Long = 31&
Private Const SM_CXFRAME              As Long = 32&
Private Const SM_CYFRAME              As Long = 33&
Private Const SM_CXMINTRACK           As Long = 34&
Private Const SM_CYMINTRACK           As Long = 35&
Private Const SM_CXDOUBLECLK          As Long = 36&
Private Const SM_CYDOUBLECLK          As Long = 37&
Private Const SM_CXICONSPACING        As Long = 38&
Private Const SM_CYICONSPACING        As Long = 39&
Private Const SM_MENUDROPALIGNMENT    As Long = 40&
Private Const SM_PENWINDOWS           As Long = 41&
Private Const SM_DBCSENABLED          As Long = 42&
Private Const SM_CMOUSEBUTTONS        As Long = 43&

'#if(WINVER >= 0x0400)
Private Const SM_CXFIXEDFRAME         As Long = SM_CXDLGFRAME  '/* ;win40 name change */
Private Const SM_CYFIXEDFRAME         As Long = SM_CYDLGFRAME  '/* ;win40 name change */
Private Const SM_CXSIZEFRAME          As Long = SM_CXFRAME     '/* ;win40 name change */
Private Const SM_CYSIZEFRAME          As Long = SM_CYFRAME     '/* ;win40 name change */

Private Const SM_SECURE               As Long = 44&
Private Const SM_CXEDGE               As Long = 45&
Private Const SM_CYEDGE               As Long = 46&
Private Const SM_CXMINSPACING         As Long = 47&
Private Const SM_CYMINSPACING         As Long = 48&
Private Const SM_CXSMICON             As Long = 49&
Private Const SM_CYSMICON             As Long = 50&
Private Const SM_CYSMCAPTION          As Long = 51&
Private Const SM_CXSMSIZE             As Long = 52&
Private Const SM_CYSMSIZE             As Long = 53&
Private Const SM_CXMENUSIZE           As Long = 54&
Private Const SM_CYMENUSIZE           As Long = 55&
Private Const SM_ARRANGE              As Long = 56&
Private Const SM_CXMINIMIZED          As Long = 57&
Private Const SM_CYMINIMIZED          As Long = 58&
Private Const SM_CXMAXTRACK           As Long = 59&
Private Const SM_CYMAXTRACK           As Long = 60&
Private Const SM_CXMAXIMIZED          As Long = 61&
Private Const SM_CYMAXIMIZED          As Long = 62&
Private Const SM_NETWORK              As Long = 63&
Private Const SM_CLEANBOOT            As Long = 67&
Private Const SM_CXDRAG               As Long = 68&
Private Const SM_CYDRAG               As Long = 69&
'#endif /* WINVER >= 0x0400 */

Private Const SM_SHOWSOUNDS           As Long = 70&

'#if(WINVER >= 0x0400)
Private Const SM_CXMENUCHECK          As Long = 71&   '/* Use instead of GetMenuCheckMarkDimensions()! */
Private Const SM_CYMENUCHECK          As Long = 72&
Private Const SM_SLOWMACHINE          As Long = 73&
Private Const SM_MIDEASTENABLED       As Long = 74&
'#endif /* WINVER >= 0x0400 */

'#if (WINVER >= 0x0500) || (_WIN32_WINNT >= 0x0400)
Private Const SM_MOUSEWHEELPRESENT    As Long = 75&
'#endif

'#if(WINVER >= 0x0500)
Private Const SM_XVIRTUALSCREEN       As Long = 76&
Private Const SM_YVIRTUALSCREEN       As Long = 77&
Private Const SM_CXVIRTUALSCREEN      As Long = 78&
Private Const SM_CYVIRTUALSCREEN      As Long = 79&
Private Const SM_CMONITORS            As Long = 80&
Private Const SM_SAMEDISPLAYFORMAT    As Long = 81&
'#endif /* WINVER >= 0x0500 */

'#if (WINVER < 0x0500) && (!defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400))
'Private Const SM_CMETRICS             As Long = 76&
'#else
Private Const SM_CMETRICS             As Long = 83&
'#endif

Private Type POINTS
        x  As Integer
        y  As Integer
End Type

'/* Rect Struct */
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private mlngMessage         As Long
Private mstrToolTip         As String
Private mblnExit            As Boolean
Private mudtNotifyIconData  As mtypNotifyIconData
    
'*===========================================================*
'概要      :ポップアップメニュー表示処理
'引数      :Menu,           I,  Object,     メニューオブジェクト
'          :flags,          I,  Variant,    メニューの表示位置と動作
'          :X,              I,  Variant,    X座標。省略時はCurrentX
'          :Y,              I,  Variant,    Y座標。省略時はCurrentY
'          :DefaultMenu,    I,  Variant,    太字で表示するメニュー
Public Sub pPopupMenu(ByVal Menu As Object, Optional ByVal flags As Variant, Optional ByVal x As Variant, Optional ByVal y As Variant, Optional ByVal DefaultMenu As Variant)
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================
    
    Call SetForegroundWindow(UserControl.hwnd)
    Call UserControl.PopupMenu(Menu, flags, x, y, DefaultMenu)
    Call PostMessage(UserControl.hwnd, WM_NULL, 0&, 0&)
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".PopupMenu" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Sub

'*===========================================================*
'概要      :表示アイコンプロパティ
'引数      :なし
'戻り値    :アイコンオブジェクト
Public Property Get Icon() As stdole.IPictureDisp
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    Set Icon = imgIcon.Picture
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Property
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".Icon" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Property

'*===========================================================*
'概要      :表示アイコンプロパティ
'引数      :pobjData,   I,  StdPicture, アイコンオブジェクト
Public Property Set Icon(ByVal pobjData As stdole.IPictureDisp)
'============= Declare ==============
Dim lngRet  As Long
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    
    If Not Ambient.UserMode Then
        If Not pobjData Is Nothing Then
            lngRet = DrawIconEx(UserControl.hdc, 0&, 0&, pobjData.Handle, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON), 0&, 0&, DI_NORMAL)
            Call pDllErrRaise(Err.LastDllError, "user32")
            Call UserControl.Refresh
        End If
        Exit Property
    End If
    Set imgIcon.Picture = pobjData
    PropertyChanged "Icon"
    
    Call UpdateTray
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Property
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".Icon" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Property

'*===========================================================*
'概要      :トレイ表示の有無
'引数      :なし
'戻り値    :True = 表示 False = 表示しない
Public Property Get InTray() As Boolean
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00

'============= Main =================

    InTray = mblnPropInTray
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Property
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".InTray" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Property

'*===========================================================*
'概要      :トレイ表示の有無
'引数      :pblnData,   I,  Boolean,    True = 表示 False = 表示しない
Public Property Let InTray(ByVal pblnData As Boolean)
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00

'============= Main =================

    mblnPropInTray = pblnData
    PropertyChanged "InTray"
    
    If Not Ambient.UserMode Then
        Exit Property
    End If
    Call UpdateTray
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Property
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".InTray" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Property

'*===========================================================*
'概要      :ツールチップ
'引数      :なし
'戻り値    :ツールチップ文字列
Public Property Get ToolTipText() As String
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00

'============= Main =================

    ToolTipText = mstrToolTip
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Property
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".ToolTipText" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Property

'*===========================================================*
'概要      :ツールチップ
'引数      :pstrData,   I,  String, ツールチップに表示する文字列
Public Property Let ToolTipText(ByVal pstrData As String)
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    mstrToolTip = pstrData
    
    If Not Ambient.UserMode Then
        Exit Property
    End If
    
    Call UpdateTray
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Property
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".ToolTipText" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Property

'*===========================================================*
'概要      :トレイ更新処理
'引数      :なし
'説明      :プロパティに応じ、トレイの表示を更新する
'戻り値    :なし
Private Sub UpdateTray()
'============= Declare ==============
Dim lngMsg      As Long
Dim lngRet      As Long

'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    Select Case mlngMessage
    Case NIM_ADD, NIM_MODIFY
        If mblnPropInTray Then
            lngMsg = NIM_MODIFY
        Else
            lngMsg = NIM_DELETE
        End If
    Case NIM_DELETE
        If mblnPropInTray Then
            lngMsg = NIM_ADD
        Else
            Exit Sub
        End If
    Case Else
    End Select
    
    With mudtNotifyIconData
        .cbSize = Len(mudtNotifyIconData)
        .hIcon = imgIcon.Picture.Handle
        .hwnd = UserControl.hwnd
        .szTip = mstrToolTip & vbNullChar
        .uCallbackMessage = WM_MBUTTONDOWN
        .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
    End With
    
    lngRet = Shell_NotifyIcon(lngMsg, mudtNotifyIconData)
    Call pDllErrRaise(Err.LastDllError, "SHELL32")
    
    mlngMessage = lngMsg
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".UpdateTray" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Sub

'*===========================================================*
'概要      :下位2ワード取得
'引数      :dwValue,    I,  Long,   取得元のDWORD値
'戻り値    :下位2ワード
Private Function LOWORD(ByVal dwValue As Long) As Integer
Dim intVal  As Integer
    
    '#define LOWORD(l)   ((WORD) (l))
    Call MoveMemory(intVal, dwValue, 2)
    LOWORD = intVal
End Function

'*===========================================================*
'概要      :上位2ワード取得
'引数      :dwValue,    I,  Long,   取得元のDWORD値
'戻り値    :なし
Private Function HIWORD(ByVal dwValue As Long) As Integer
Dim intVal  As Integer
    
    '#define HIWORD(l)   ((WORD) (((DWORD) (l) &gt;> 16) & 0xFFFF))
    Call MoveMemory(intVal, ByVal VarPtr(dwValue) + 2, 2)   '微妙?
    HIWORD = intVal
End Function

'*===========================================================*
'概要      :コントロール初期化
'引数      :なし
'説明      :変数初期化等
'戻り値    :なし
Private Sub UserControl_Initialize()
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    mlngMessage = NIM_DELETE
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".UserControl_Initialize" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
    Call Err.Clear
    Resume EXIT_HNDL_00

End Sub

'*===========================================================*
'概要      :メッセージ処理
'引数      :Button, I,  Integer,    ┐この2つが以下に対応する?
'          :Shift,  I,  Integer,    ┘fwKeys = wParam;      // key flags
'          :X,      I,  Single,     xPos = LOWORD(lParam);  // horizontal position of cursor
'          :Y,      I,  Single,     yPos = HIWORD(lParam);  // vertical position of cursor
'説明      :タスクトレイからの通知を処理する
'戻り値    :なし
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
'============= Declare ==============
Dim udtPoints       As POINTS
Dim lnglParam       As Long
Dim lngwParam       As Long

'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================
    
    'ウインドウプロシージャのオリジナルのパラメータを取得する
    With udtPoints
        .x = CInt(UserControl.ScaleX(x, vbTwips, vbPixels))
        .y = CInt(UserControl.ScaleY(y, vbTwips, vbPixels))
    End With
    Call MoveMemory(lnglParam, udtPoints, Len(udtPoints))   '本来のlParamを取得
    
    '通知の内容を判断する
    'The wParam parameter of the message contains the identifier of the taskbar icon in which the event occurred.   →取得困難なため捨てる
    'The lParam parameter holds the mouse or keyboard message associated with the event.
    If (Button And vbMiddleButton) Then
        Select Case lnglParam
        Case WM_MOUSEMOVE
            RaiseEvent MouseMove
        Case WM_LBUTTONDOWN
            RaiseEvent MouseDown(vbLeftButton)
        Case WM_LBUTTONUP
            RaiseEvent MouseUp(vbLeftButton)
        Case WM_LBUTTONDBLCLK
            RaiseEvent DblClick
        Case WM_RBUTTONDOWN
            RaiseEvent MouseDown(vbRightButton)
        Case WM_RBUTTONUP
            RaiseEvent MouseUp(vbLeftButton)
        Case WM_RBUTTONDBLCLK       'Shell_NotifyIconからはこないらしい
            RaiseEvent DblClick
        Case WM_MBUTTONDOWN
            RaiseEvent MouseDown(vbMiddleButton)
        Case WM_MBUTTONUP
            RaiseEvent MouseUp(vbMiddleButton)
        Case WM_MBUTTONDBLCLK
        End Select
    End If
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call MsgBox(CNST_MODULE_NAME & ".UserControl_MouseDown" & "(" & Err.Source & ")" & vbCrLf & Format$(Err.Number, "0""=""") & Err.Description, vbCritical)
    Call Err.Clear
    Resume EXIT_HNDL_00
End Sub

'*===========================================================*
'概要      :プロパティロード処理
'引数      :PropBag,    I,  VBRUN.PropertyBag,  プロパティバッグ
'説明      :プロパティを読み込む
'戻り値    :なし
Private Sub UserControl_ReadProperties(PropBag As VBRUN.PropertyBag)
'============= Declare ==============
Dim lngRet  As Long
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================
    
    'プロパティを読み込む
    mstrToolTip = PropBag.ReadProperty("ToolTipText", "")
    Set imgIcon.Picture = PropBag.ReadProperty("Icon", Nothing)
    mblnPropInTray = PropBag.ReadProperty("InTray", mcblnPROP_INTRAY)
    
    '実行中でなければ小さいアイコンを描画する
    If Not Ambient.UserMode Then
        If imgIcon.Picture <> 0& Then
            lngRet = DrawIconEx(UserControl.hdc, 0&, 0&, imgIcon.Picture.Handle, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON), 0&, 0&, DI_NORMAL)
            Call pDllErrRaise(Err.LastDllError, "user32")
            Call UserControl.Refresh
        End If
        Exit Sub
    End If
    
    'トレイ表示を更新する
    If mblnPropInTray Then
        Call UpdateTray
    End If
    
    mblnExit = True
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".UserControl_ReadProperties" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
    Resume EXIT_HNDL_00
End Sub

'*===========================================================*
'概要      :コントロールリサイズ時処理
'引数      :なし
'説明      :コントロールがリサイズされないようにする
'戻り値    :なし
Private Sub UserControl_Resize()
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================
    
    With UserControl
        .Width = .ScaleX(28!, vbPixels, vbTwips)
        .Height = .ScaleY(28!, vbPixels, vbTwips)
    End With

'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call MsgBox(CNST_MODULE_NAME & ".UserControl_Resize" & "(" & Err.Source & ")" & vbCrLf & Format$(Err.Number, "0""=""") & Err.Description, vbCritical)
    Call Err.Clear
    Resume Next
End Sub

'*===========================================================*
'概要      :コントロール破棄時処理
'引数      :なし
'説明      :トレイからアイコンを削除する
'戻り値    :なし
Private Sub UserControl_Terminate()
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    mblnPropInTray = False
    If mlngMessage <> NIM_DELETE Then
        Call UpdateTray
    End If
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".UserControl_Terminate" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
    Call Err.Clear
    Resume EXIT_HNDL_00
End Sub

'*===========================================================*
'概要      :プロパティ書き込み処理
'引数      :PropBag,    I,  VBRUN.PropertyBag,  プロパティバッグ
'説明      :プロパティを保存する
'戻り値    :なし
Private Sub UserControl_WriteProperties(PropBag As VBRUN.PropertyBag)
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================
    
    Call PropBag.WriteProperty("ToolTipText", mstrToolTip, "")
    Call PropBag.WriteProperty("Icon", imgIcon.Picture, Nothing)
    Call PropBag.WriteProperty("InTray", mblnPropInTray, mcblnPROP_INTRAY)
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".UserControl_WriteProperties" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
    Call Err.Clear
    Resume EXIT_HNDL_00
End Sub

'*===========================================================*
'概要      :プロパティ初期化時処理
'引数      :なし
'説明      :プロパティを初期値に設定する
'戻り値    :なし
Private Sub UserControl_InitProperties()
'============= Declare ==============
'============= Initiarize ===========
On Error GoTo ERR_HNDL_00
    
'============= Main =================

    mblnPropInTray = mcblnPROP_INTRAY
    
'============= Release ==============
EXIT_HNDL_00:
    Exit Sub
'============= Error ================
ERR_HNDL_00:
'    Call Err.Raise(vbObjectError Or Err.Number, CNST_MODULE_NAME & ".UserControl_InitProperties" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
    Call Err.Clear
    Resume EXIT_HNDL_00

End Sub

frog.raindrop.jp.knowledge

February 8, 2004

タスクトレイにアイコンを表示するユーザーコントロール

トラックバック

コメント

コメントする