ステータスバーにメッセージを表示する：Outlook VBA

Option Explicit On

Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
End Type

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
'アクティブウィンドウハンドルを取得する'
Private Declare Function GetActiveWindow Lib "user32" () As Long
'ウィンドウタイトル取得'
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd&, ByVal lpString$, ByVal cch&) As Long
'ウィンドウタイトル変更'
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Declare Function GetWindowRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
' ウィンドウのサイズ、位置、および Z オーダーを設定。（ウィンドウの重なり順のことを「Zオーダー」といいZオーダーのトップに置くと一番手前に表示される）'
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

' ブラシ '
Const BS_SOLID = 0
Const BS_HOLLOW = 1
Const BS_NULL = 1
Const BS_HATCHED = 2
Const BS_PATTERN = 3
Const BS_DIBPATTERN = 5
Const BS_DIBPATTERNPT = 6
Const HS_HORIZONTAL = 0
Const HS_VERTICAL = 1
Const HS_FDIAGONAL = 2
Const HS_BDIAGONAL = 3
Const HS_CROSS = 4
Const HS_DIAGCROSS = 5
' Window Message '
Const WM_SETTEXT = &HC
Const WM_GETTEXT = &HD
Const WM_GETTEXTLENGTH = &HE
Const WM_SETFONT = &H30
Const WM_CTLCOLORSTATIC = &H138
' Status Bar Message '
Const SB_SETTEXT = &H401
Const SB_GETTEXT = &H402
Const SB_GETTEXTLENGTH = &H403
Const SB_GETPARTS = &H406
Const SBT_NOBORDERS = &H100
' Button Message '
Const BM_CLICK = &HF5
' Get Window '
Const GW_HWNDFIRST = 0  '基準となるWindowと同じ種類のうち最前面のWindow'
Const GW_HWNDLAST = 1   '基準となるWindowと同じ種類のうち最背面のWindow'
Const GW_HWNDNEXT = 2   '基準となるWindowの次のWindow'
Const GW_HWNDPREV = 3   '基準となるWindowの前のWindow'
Const GW_OWNER = 4      '基準となるWindowのオーナーWindow'
Const GW_CHILD = 5      '基準となるWindowの子WindowのうちトップレベルのWindow'
' Window Style '
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_EX_LEFT = 0
' ペン '
Const PS_SOLID = 0
Const PS_DASH = 1
Const PS_DOT = 2
Const PS_DASHDOT = 3
Const PS_DASHDOTDOT = 4
Const PS_NULL = 5
Const PS_INSIDEFRAME = 6
' Font Weight@CreateFont '
Const FW_DONTCARE = 0
Const FW_THIN = 100
Const FW_EXTRALIGHT = 200
Const FW_LIGHT = 300
Const FW_NORMAL = 400
Const FW_MEDIUM = 500
Const FW_SEMIBOLD = 600
Const FW_BOLD = 700
Const FW_EXTRABOLD = 800
Const FW_HEAVY = 900
' CHARSET@CreateFont '
Const ANSI_CHARSET = 0
Const DEFAULT_CHARSET = 1
Const OEM_CHARSET = 255
Const SHIFTJIS_CHARSET = 128
Const SYMBOL_CHARSET = 2
Const BALTIC_CHARSET = 186
Const CHINESEBIG5_CHARSET = 136
Const EASTEUROPE_CHARSET = 238
Const GREEK_CHARSET = 161
Const HANGEUL_CHARSET = 129
Const MAC_CHARSET = 77
Const RUSSIAN_CHARSET = 204
Const TURKISH_CHARSET = 162
' 物理フォントを検索するための方法@CreateFont '
Const OUT_CHARACTER_PRECIS = 2
Const OUT_DEFAULT_PRECIS = 0
Const OUT_DEVICE_PRECIS = 5
Const OUT_OUTLINE_PRECIS = 8
Const OUT_RASTER_PRECIS = 6
Const OUT_STRING_PRECIS = 1
Const OUT_STROKE_PRECIS = 3
Const OUT_TT_ONLY_PRECIS = 7
Const OUT_TT_PRECIS = 4
' Cliping@CreateFont'
Const CLIP_DEFAULT_PRECIS = 0
Const CLIP_EMBEDDED = 128
Const CLIP_LH_ANGLES = 16
Const CLIP_MASK = &HF
Const CLIP_STROKE_PRECIS = 2
Const CLIP_TO_PATH = 4097
Const CLIP_TT_ALWAYS = 32
' 文字品質@CreateFont '
Const DEFAULT_QUALITY = 0
Const DRAFT_QUALITY = 1
Const PROOF_QUALITY = 2
' フォントのピッチとファミリの指定@CreateFont '
' 下位2bit=ピッチ, 上位4bit=フォントファミリ '
Const DEFAULT_PITCH = 0
Const FIXED_PITCH = 1
Const VARIABLE_PITCH = 2
Const FF_DECORATIVE = 80
Const FF_DONTCARE = 0
Const FF_MODERN = 48
Const FF_ROMAN = 16
Const FF_SCRIPT = 64
Const FF_SWISS = 32
'書式制御フラグ@DrawText '
Const DT_BOTTOM = &H8
Const DT_CALCRECT = &H400
Const DT_CENTER = &H1
Const DT_CHARSTREAM = 4
Const DT_DISPFILE = 6
Const DT_EXPANDTABS = &H40
Const DT_EXTERNALLEADING = &H200
Const DT_INTERNAL = &H1000
Const DT_METAFILE = 5
Const DT_LEFT = &H0
Const DT_NOCLIP = &H100
Const DT_NOPREFIX = &H800
Const DT_PLOTTER = 0
Const DT_RASCAMERA = 3
Const DT_RASDISPLAY = 1
Const DT_RASPRINTER = 2
Const DT_RIGHT = &H2
Const DT_SINGLELINE = &H20
Const DT_TABSTOP = &H80
Const DT_TOP = &H0
Const DT_VCENTER = &H4
Const DT_WORDBREAK = &H10
' カラー情報フラグ '
Const DIB_RGB_COLORS = 0
Const DIB_PAL_COLORS = 1
Const DIB_PAL_INDICES = 2
' 取得するストックオブジェクトの型@GetStockObject '
Const NULL_BRUSH = 5
Const BLACK_BRUSH = 4
Const DKGRAY_BRUSH = 3
Const GRAY_BRUSH = 2
Const HOLLOW_BRUSH = NULL_BRUSH
Const LTGRAY_BRUSH = 1
Const WHITE_BRUSH = 0
Const BLACK_PEN = 7
Const WHITE_PEN = 6
Const ANSI_FIXED_FONT = 11
Const ANSI_VAR_FONT = 12
Const DEVICE_DEFAULT_FONT = 14
Const DEFAULT_GUI_FONT = 17
Const OEM_FIXED_FONT = 10
Const SYSTEM_FONT = 13
Const SYSTEM_FIXED_FONT = 16
Const DEFAULT_PALETTE = 15
' GetWindowLong 関数で取得する情報の指定 '
Public Const GWL_HINSTANCE = (-6) 'インスタンスハンドルを取得'
Public Const GWL_HWNDPARENT = (-8) '親ウインドウのハンドルを取得'
Public Const GWL_ID = (-12) 'ウインドウのIDを取得'
Public Const GWL_EXSTYLE = (-20) '拡張ウインドウスタイルを取得'
Public Const GWL_STYLE = (-16) 'ウインドウスタイルを取得'
Public Const GWL_WNDPROC = (-4) 'ウインドウ関数のアドレスを取得'
Public Const GWL_USERDATA = (-21) 'ユーザー定義の32ビット値を取得'
' ShowWindow 指定されたウィンドウの表示状態を設定'
Const SW_HIDE = 0                      '指定のウインドウを非表示にし他のウインドウをアクティブ化'
Const SW_SHOW = 5                      'ウインドウをアクティブ化し現在の位置とサイズで表示'
Const SW_SHOWMINNOACTIVE = 7           'ウインドウをアイコン化する。現在アクティブなウインドウはアクティブなままにする'
Const SW_RESTORE = 9                   'ウインドウをアクティブ化し表示。ウインドウがアイコン化または最大化されているときは元の位置とサイズに'
' ShowWindowPos '
Const SWP_SHOWWINDOW = &H40            'ウインドウを表示する'
Const SWP_NOSIZE = &H1                 'ウインドウの現在のサイズを保持する'
Const SWP_NOMOVE = &H2                 'ウインドウの現在位置を保持する'
Const HWND_TOP = 0                     'ウインドウをZオーダーの一番上に配置する'
Const HWND_BOTTOM = 1                  'ウインドウをウインドウリストの一番下に配置する'
Const HWND_TOPMOST = -1                'ウインドウをウインドウリストの一番上に配置する'
Const HWND_NOTOPMOST = -2              'ウインドウをウインドウリストの一番上に配置する'
' SetBkMode '
Const TRANSPARENT = 1
Const OPAQUE = 2
' Text Control Style '
Const SS_LEFT = &H0
Const SS_CENTER = &H1
Const SS_RIGHT = &H2
Const SS_ICON = &H3
Const SS_BLACKRECT = &H4
Const SS_GRAYRECT = &H5
Const SS_WHITERECT = &H6
Const SS_BLACKFRAME = &H7
Const SS_GRAYFRAME = &H8
Const SS_WHITEFRAME = &H9
Const SS_USERITEM = &HA
Const SS_SIMPLE = &HB
Const SS_LEFTNOWORDWRAP = &HC
Const SS_OWNERDRAW = &HD
Const SS_BITMAP = &HE
Const SS_ENHMETAFILE = &HF
Const SS_ETCHEDHORZ = &H10
Const SS_ETCHEDVERT = &H11
Const SS_ETCHEDFRAME = &H12
Const SS_NOPREFIX = &H80
Const SS_NOTIFY = &H100
Const SS_CENTERIMAGE = &H200
Const SS_RIGHTJUST = &H400
Const SS_REALSIZEIMAGE = &H800
Const SS_SUNKEN = &H1000
Const SS_ENDELLIPSIS = &H4000
Const SS_PATHELLIPSIS = &H8000
Const SS_WORDELLIPSIS = &HC000

Dim StatWnd As Long
' ウィンドウプロシージャのサブクラス化'
Dim proc_org As Collection
' 独自の処理を追加する場所'
' 処理を行った場合は1を返す。（行わない場合0）'
' result に戻り値を渡す。'
Private Function MyWinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef result As Long) As Long
    Select Case uMsg
        Case WM_CTLCOLORSTATIC
            If lParam = StatWnd Then
                Dim hdc As Long
                hdc = wParam
                SetTextColor hdc, vbWhite
                SetBkMode hdc, OPAQUE
                SetBkColor hdc, RGB(0, 114, 198)
                Dim hNewBrush As Long
                Dim hOldBrush As Long
                Dim NewBrush As LOGBRUSH
                NewBrush.lbColor = RGB(0, 114, 198)
                NewBrush.lbStyle = BS_SOLID
                NewBrush.lbHatch = HS_HORIZONTAL
                hNewBrush = CreateBrushIndirect(NewBrush)
                hOldBrush = SelectObject(hdc, hNewBrush)
                MyWinProc = 1
            End If
        Case Else
            MyWinProc = 0
    End Select
End Function
' ウィンドウプロシージャ'
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim proc As Long
    Dim result As Long
    proc = proc_org.Item(CStr(hwnd))
    If MyWinProc(hwnd, uMsg, wParam, lParam, result) = 0 Then
        WindowProc = CallWindowProc(proc, hwnd, uMsg, wParam, lParam)
    Else
        WindowProc = result
    End If
End Function
' サブクラス化'
Public Sub alloc_subclass(ByVal hwnd As Long)
    Static flag As Boolean
    If flag = False Then
        Set proc_org = New Collection
        flag = True
    End If
    Dim proc As Long
    proc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
    proc_org.Add proc, Key:=CStr(hwnd)
End Sub
' サブクラス解放'
Public Sub free_subclass(ByVal hwnd As Long)
    Dim result As Long
    Dim proc As Long
    proc = proc_org.Item(CStr(hwnd))
    result = SetWindowLong(hwnd, GWL_WNDPROC, proc)
    proc_org.Remove CStr(hwnd)
End Sub
Private Sub DestroyStat(ByVal hwnd As Long)
    Dim hWnd2 As Long
    hWnd2 = FindWindowEx(hwnd, 0, "MsoCommandBarDock", "MsoDockBottom")
    Call free_subclass(hWnd2)
    DestroyWindow StatWnd
    StatWnd = 0
End Sub
Private Sub ChangeStatusBarText(hwnd As Long, new_title As String)
    Dim hWnd2 As Long
    Dim length As Long
    Dim dspstr As String
    Dim lParam As Long
    Dim wPalam As Long
    Dim countlim As Long
    Dim hInstance As Long
    Dim hFont As Long
    lParam = 0
    If StatWnd = 0 Then
        hWnd2 = FindWindowEx(hwnd, 0, "MsoCommandBarDock", "MsoDockBottom")
        length = SendMessage(hWnd2, WM_GETTEXTLENGTH, 0, Nothing)
        dspstr = String(length, vbNullChar)
        Call SendMessage(hWnd2, WM_GETTEXT, length + 1, dspstr)
        hFont = CreateFont(16, 0, 0, 0, FW_NORMAL, False, False, 0, SHIFTJIS_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, "Meiryo UI")
        hInstance = GetWindowLong(hwnd, GWL_HINSTANCE)
        Call alloc_subclass(hWnd2)
        StatWnd = CreateWindowEX(WS_EX_LEFT, "STATIC", new_title, WS_CHILD Or WS_VISIBLE Or SS_LEFT, 6, 2, 400, 18, hWnd2, 0, hInstance, lParam)
        Dim rct As RECT
        Call SendMessage(StatWnd, WM_SETFONT, hFont, 0&)
        Call SendMessage(StatWnd, WM_SETTEXT, 0, new_title)
        Call SetWindowPos(StatWnd, HWND_TOP, 0, 0, 0, 0, SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE)
        Call GetWindowRect(StatWnd, rct)
    Else
        SendMessage StatWnd, WM_SETTEXT, 0, new_title
    End If
    DoEvents
End Sub
Public Function EnumChild2(ByVal hwnd As Long, ByVal lParam As Object) As Long
    Call EnumChild(hwnd, lParam)
End Function
Public Function EnumChild(ByVal hwnd As Long, ByVal lParam As Object) As Long
    EnumChild = True
    Dim dat As Dictionary
    Set dat = lParam
    ' Window情報を取得するための領域の確保
    Dim strClassName As String ' * 255
    Dim strCaption As String ' * 255
    strClassName = String(255, vbNullChar)
    strCaption = String(255, vbNullChar)
    ' Win32APIによりWindow情報を取得
    GetWindowText hwnd, strCaption, Len(strCaption)
    GetClassName hwnd, strClassName, Len(strClassName)
    ' 取得した文字列から不要な部分を削除
    strCaption = RTrim(Left(strCaption, InStr(1, strCaption, vbNullChar) - 1))
    strClassName = RTrim(Left(strClassName, InStr(1, strClassName, vbNullChar) - 1))
End Function

Sub 使い方()
    ' Outlookのウィンドウ取得
    Dim exp As Explorer
    Set exp = ActiveExplorer
    Dim hwnd As Long
    hwnd = FindWindow("rctrl_renwnd32", exp.Caption)
    ' ステータスバーのメッセージ変更
    Call ChangeStatusBarText(hwnd, "設定したいメッセージ")
    Call ChangeStatusBarText(hwnd, "")
    Call DestroyStat(hwnd)
End Sub