● 常に手前または後ろに表示する ●

有名すぎるネタかな。この機能は自作のメモ帳に組み込みたい。メモ帳を常に手前表示にするととっても便利〜、ホントに。

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

Private 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 Const HWND_TOP = 0          '手前にセット
Private Const HWND_BOTTOM = 1       '後ろにセット
Private Const HWND_TOPMOST = -1     '常に手前にセット
Private Const HWND_NOTOPMOST = -2   '常に手前、解除

Private Const SWP_SHOWWINDOW = &H40  '表示する

'---------------------------------------------------------------------------
' 関数名: SetAlwaysTop
' 機能  : ウィンドウを常に手前に表示する
' 引数  : (in) hWnd … 常に手前表示したいウィンドウのハンドル
'          (in) IsTopMost … True:常に手前表示   False:常に手前表示解除
' 戻り値: 正常:0以外、 エラー:0
'---------------------------------------------------------------------------
Public Function SetAlwaysTop(ByVal hWnd As Long, _
                    Optional ByVal IsTopMost As Boolean = True) As Long

    Dim udtRect As RECT

    'ウインドウの座標を取得する
    Call GetWindowRect(hWnd, udtRect)

    '常に手前に表示する
    SetAlwaysTop = SetWindowPos(hWnd, _
                                IIf(IsTopMost, HWND_TOPMOST, HWND_NOTOPMOST), _
                                udtRect.Left, _
                                udtRect.Top, _
                                udtRect.Right - udtRect.Left, _
                                udtRect.Bottom - udtRect.Top, _
                                SWP_SHOWWINDOW)

End Function


ついでに常に後ろに表示するサンプル。たちまちウィンドウが奥床しくなる。

Private Type WINDOWPOS
    hWnd As Long
    hWndInsertAfter As Long
    x As Long
    y As Long
    cx As Long
    cy As Long
    flags As Long
End Type

'デフォルトのウィンドウ・プロシージャを呼ぶ
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

'ウィンドウの属性を設定する
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'メモリコピー
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Private Const HWND_BOTTOM As Long = 1
Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_WINDOWPOSCHANGING = &H46

Public OldWindowhWnd As Long

'-----------------------------------------------------------------------
' 関数名 : SubClass
' 機能   : サブクラス化を開始する
' 引数   : (in) hWnd  … コールバック対象となるウインドウのハンドル
' 戻り値 : なし
'-----------------------------------------------------------------------
Public Function SubClass(ByVal hWnd As Long) As Long
    OldWindowhWnd = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
    SubClass = OldWindowhWnd
End Function


'-----------------------------------------------------------------------
' 関数名 : UnSubClass
' 機能   : サブクラス化を終了する
' 引数   : (in) hWnd  … コールバック対象となるウインドウのハンドル
' 戻り値 : なし
'-----------------------------------------------------------------------
Public Sub UnSubClass(ByVal hWnd As Long)
    Dim FuncRet As Long

    If OldWindowhWnd <> 0 Then
        '元のプロシージャアドレスに設定する
        FuncRet = SetWindowLong(hWnd, GWL_WNDPROC, OldWindowhWnd)
        OldWindowhWnd = 0
    End If
End Sub


'-----------------------------------------------------------------------
' 関数名:WindowProc
' 機  能:いわずとしれたウインドウプロシージャ
'-----------------------------------------------------------------------
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                      ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim udtWinPos As WINDOWPOS

    Select Case uMsg
        Case WM_WINDOWPOSCHANGING
            Call CopyMemory(udtWinPos, ByVal lParam, Len(udtWinPos))
            udtWinPos.hWndInsertAfter = HWND_BOTTOM
            Call CopyMemory(ByVal lParam, udtWinPos, Len(udtWinPos))
            WindowProc = 0&
            Exit Function
    End Select

    WindowProc = CallWindowProc(OldWindowhWnd, hWnd, uMsg, wParam, lParam)

End Function

あとは例によって以下の実装。

Private Sub Form_Load()

    'サブクラス化開始
    Call SubClass(Me.hWnd)

End Sub

Private Sub Form_Unload(Cancel As Integer)

    'サブクラス化終了
    Call UnSubClass(Me.hWnd)

End Sub

戻る