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 件のコメント:
コメントを投稿