2011年3月24日木曜日

VBAからシステムアイコントレイを使う

Excel,Accessで動きます

WindowsXP Office2003で開発しました。
古いWindows APIを使っていますが、おそらく最新のものでも動きます。

システムアイコントレイとはタスクバーの右にあるアイコン達です。
なにかイベントをお知らせしてくれたり進捗状況をポップアップで表示します。
それをVBAで実現します。

ExcelはWindowsメッセージループが隠蔽されており完璧な動作はできませんが、
使い方によってはMsgBoxなどよりも手軽でユーザーの邪魔になりません。

・サンプルモジュール[Ml_NOTIFYICON.bas]
Option Explicit

Public Sub test()
    
    Dim cls_Icon As New Cl_NOTIFYICON 'NOTIFYICONオブジェクト
    
    Call cls_Icon.AddIcon(Application.hWnd, "アイコンてすと") 'システムトレイにアイコンを登録
    
    MsgBox "システムトレイにアイコンが追加されました"
    
    Call cls_Icon.ShowBalloon("バルーンメッセージてすと", "バルーンタイトル", NIIF_INFO, 10)       'バルーンチップの表示
    
    MsgBox "バルーンチップが表示されました"
    
    Call cls_Icon.ModifyIcon("C:\windows\system32\notepad.exe") 'アイコンの変更
    
    MsgBox "アイコンを変更しました"
    
    Call cls_Icon.DeleteIcon 'アイコンの削除
    
    MsgBox "アイコンを削除しました"
    
    Set cls_Icon = Nothing 'オブジェクト破棄、デストラクタの呼び出し

End Sub
・クラス[Cl_NOTIFYICON.cls]
Option Explicit

'user defined type required by Shell_NotifyIcon API call
'アイコン情報の構造体
Private Type NOTIFYICONDATA
    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
    uTimeoutOrVersion As Long
    szInfoTitle As String * 64
    dwInfoFlags As Long
End Type

Public Enum NOTIFYICONINFO
    NIIF_NONE = &H0 'アイコンなし
    NIIF_INFO = &H1 '「情報」アイコン
    NIIF_WARNING = &H2 '「警告」アイコン
    NIIF_ERROR = &H3 '「エラー」アイコン
    NIIF_USER = &H4
    NIIF_ICON_MASK = &HF 'Version 6.0 以降: 予約されています。
    NIIF_NOSOUND = &H10 'Version 6.0 以降: 関連サウンドを鳴らさないようにします。バルーンツールチップにのみ適用されます。
End Enum

'constants required by Shell_NotifyIcon API call:
'アイコンに対する処理命令
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2

Private Const NIF_MESSAGE = &H1 'uCallbackMessage
Private Const NIF_ICON = &H2    'hIcon
Private Const NIF_TIP = &H4     'szTip
Private Const NIF_STATE = &H8   'Version 5.0 以降: dwState, dwStateMask
Private Const NIF_INFO = &H10   'Version 5.0 以降: szInfo, uTimeout, szInfoTitle, dwInfoFlags
Private Const NIF_GUID = &H20   'Version 6.0 以降: 予約されています。
      
'使用しない
'Private Const WM_MOUSEMOVE = &H200
'Private Const WM_LBUTTONDOWN = &H201     'Button down
'Private Const WM_LBUTTONUP = &H202       'Button up
'Private Const WM_LBUTTONDBLCLK = &H203   'Double-click
'Private Const WM_RBUTTONDOWN = &H204     'Button down
'Private Const WM_RBUTTONUP = &H205       'Button up
'Private Const WM_RBUTTONDBLCLK = &H206   'Double-click

'API宣言
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Private typ_Icon As NOTIFYICONDATA '自クラスで管理するアイコンのデータ(構造体)

Public Function AddIcon(ByVal hWnd As Long, Optional ByVal ToolTip As String = "Notifyicon", Optional ByVal IconResourceFile As String = "") As Long
'=========================================================================
'機能       :アイコンをタスクトレイに追加する。
'引き数     :hwnd(アイコンの親となるウィンドウハンドル。例:エクセルのウィンドウ、アクセスのフォーム)
'             ToolTip (アイコンの上にマウスを持ってきたときに表示されるメッセージ)
'             IconResourceFile(アイコンのアイコンとなるリソース。例:DLL,EXEファイル。~EXCEL.EXEなどがいいと思います)
'返り値     :Shell_NotifyIcon関数の戻り値
'=========================================================================

    Dim IconSmall As Long

    If IconResourceFile = "" Then IconResourceFile = Application.Path & "\" & "EXCEL.EXE" 'アイコンリソースの指定がない時は自アプリから取得
    
    Call GetExtractIcon(IconResourceFile, IconSmall) 'リソースからアイコンを取得

    With typ_Icon
        .cbSize = Len(typ_Icon)
        .hWnd = hWnd
        .uID = 0
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE Or NIF_INFO
        .hIcon = IconSmall
        .szTip = ToolTip & vbNullChar
    End With
    
    DrawMenuBar hWnd
    
    AddIcon = Shell_NotifyIcon(NIM_ADD, typ_Icon)

End Function

Public Function ShowBalloon(ByVal Message As String, Optional Title As String = "Notifyicon", Optional ByVal BalloonIcon As NOTIFYICONINFO, Optional ByVal BalloonTimeOutSecond As Long = 10) As Long
'=========================================================================
'機能       :バルーンチップを表示する
'引き数     :Message(バルーンに表示するメッセージ)
'             Title (バルーンタイトル)
'             BalloonTimeOutSecond(バルーン表示がタイムアウトするまでの時間(秒)この機能は環境依存です)
'返り値     :Shell_NotifyIcon関数の戻り値
'=========================================================================

    With typ_Icon
        .cbSize = Len(typ_Icon)
        .uFlags = NIF_INFO
        .szInfoTitle = Title & vbNullChar
        .szInfo = Message & vbNullChar
        .uTimeoutOrVersion = BalloonTimeOutSecond * 1000 'タイムアウト時間(ms)
        .dwInfoFlags = BalloonIcon
    End With

    ShowBalloon = Shell_NotifyIcon(NIM_MODIFY, typ_Icon)
    
End Function

Public Function ModifyIcon(ByVal IconResourceFile) As Long
'=========================================================================
'機能       :アイコンのリソースを変更する
'返り値     :Shell_NotifyIcon関数の戻り値
'=========================================================================

    Dim IconSmall As Long
    
    Call GetExtractIcon(IconResourceFile, IconSmall)

    With typ_Icon
        .hIcon = IconSmall
        .uFlags = NIF_ICON
    End With
    
    ModifyIcon = Shell_NotifyIcon(NIM_MODIFY, typ_Icon)
    
End Function

Public Sub DeleteIcon()
'=========================================================================
'機能       :自クラスで作成したアイコンを削除する
'=========================================================================

    With typ_Icon
        .cbSize = Len(typ_Icon)
        .uFlags = NIF_ICON
        .uID = 0
    End With
    
    Call Shell_NotifyIcon(NIM_DELETE, typ_Icon) 'API実行
    
End Sub

Private Function GetExtractIcon(ByVal IconResourceFile As String, ByRef IconSmall As Long, Optional ByVal IconIndex As Long = 0) As Long
'=========================================================================
'機能       :ExtractIconEx関数のラッパ
'引き数     :IconResourceFile(アイコンリソースファイル)
'             IconIndex (リソースから取得するアイコンのインデックス)
'返り値     :ExtractIconEx関数の戻り値、関数内エラー発生時は-1
'=========================================================================

    Dim IconLarge As Long

    If Dir(IconResourceFile) = "" Then
        MsgBox IconResourceFile & "が見つかりません", , "GetExtractIcon関数エラー"
        GetExtractIcon = -1
        Exit Function
    End If
        
    GetExtractIcon = ExtractIconEx(IconResourceFile, IconIndex, IconLarge, IconSmall, 1)
    
End Function

Private Sub Class_Terminate()
    Dim typ_Dummy As NOTIFYICONDATA
    Call DeleteIcon
    typ_Icon = typ_Dummy
End Sub

0 件のコメント:

コメントを投稿