source: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Control.ab@ 615

'Classes/ActiveBasic/Windows/UI/Control.ab

#require <Classes/ActiveBasic/Windows/UI/EventArgs.ab>
#require <Classes/ActiveBasic/COM/ComClassBase.ab>

Namespace ActiveBasic
Namespace Windows
Namespace UI

Namespace Detail
    TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
End Namespace

/*
@brief Windowsのウィンドウを管理する基底クラス
@auther Egtra
*/
Class Control
    Inherits WindowHandle
    Implements ActiveBasic.COM.InterfaceQuerable
Public
    /*!
    @brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
    @date   2008/07/16
    */
    finalDestroy As ActiveBasic.Windows.UI.Handler

    Sub Control()
        comImpl = New COM.ComClassDelegationImpl(This)
    End Sub

    Function Handle() As HWND
        Handle = hwnd
    End Function

    /*!
    @brief HWNDからControlインスタンスを取得する。
    @param[in] hwnd 対象のウィンドウハンドル
    @return 対応するControlインスタンス。ただし、存在しなければNothing。
    */
    Static Function FromHWnd(hwnd As HWND) As Control
        FromHWnd = Nothing
        If _System_IsWindow(hwnd) Then
            FromHWnd = FromHWndCore(hwnd)
        End If
    End Function

Private
    Static Function FromHWndCore(hwnd As HWND) As Control
        FromHWndCore = _System_PtrObj(GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As VoidPtr) As Control
    End Function

'--------------------------------
' ウィンドウ作成

Public
    /*!
    @brief ウィンドウを作成する（詳細版）。
    @date 2008/08/02
    通常はCreateやCreateFormその他を使ってください。
    */
    Sub CreateEx(parent As Control, style As DWord, exStyle As DWord, hmenu As HMENU)
        Dim cs As CREATESTRUCT
        With cs
            .dwExStyle = exStyle
            .lpszClass = (atom As ULONG_PTR) As LPCTSTR
            .lpszName = 0
            .style = style
            .x = 0
            .y = 0
            .cx = 0
            .cy = 0
            If IsNothing(parent) Then
                .hwndParent = 0
            Else
                .hwndParent = parent As HWND
            End If
            .hMenu = hmenu
            .hInstance = hInstance
        End With
        GetCreateStruct(cs)
        createImpl(cs, parent)
    End Sub

    /*!
    @brief ウィンドウを作成する（子ウィンドウ以外）。
    @date 2008/08/02
    */
    Sub CreateForm(style As DWord, exStyle As DWord, owner = Nothing As Control, hmenu = 0 As HMENU)
        CreateEx(owner, style, exStyle, hmenu)
    End Sub

    Sub CreateForm()
        CreateEx(Nothing, 0, 0, 0)
    End Sub

    /*!
    @brief 子ウィンドウを作成する。
    @date 2008/08/02
    */
    Sub Create(parent As Control, style = 0 As DWord, exStyle = 0 As DWord, id = 0 As Long)
        CreateEx(parent, style Or WS_CHILD Or WS_VISIBLE, exStyle, id As ULONG_PTR As HMENU)
    End Sub

Protected
    Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

    Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
        throwIfAlreadyCreated()

        StartWndProc()

        With cs
            'よそのウィンドウクラスの場合、WndProcFirst内のhwndの代入が行われないため、ここでも行っておく。
            hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
                .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
            If hwnd = 0 Then
                ThrowWithLastErrorNT("Control.CreateEx")
            End If
            
            If IsNothing(FromHWndCore(hwnd)) <> False Then
                AssociateHWnd(hwnd)
                TlsSetValue(tlsIndex, 0)
            End If
        End With

        If IsNothing(parent) = False Then
            RegisterUnassociateHWnd(parent)
        End If
    End Sub

Public
    Sub Attach(hwndNew As HWND)
        throwIfAlreadyCreated()
        If hwndNew = 0 Then
            Throw New System.ArgumentNullException("Control.Attach")
        End If
        registerStandardEvent()
        AssociateHWnd(hwndNew)
        prevWndProc = SetWindowLongPtr(GWLP_WNDPROC, AddressOf(WndProcFirst) As LONG_PTR) As WNDPROC
    End Sub

Private
    Sub throwIfAlreadyCreated()
        If hwnd <> 0 Then
            Throw New System.InvalidOperationException("Window already created.")
        End If
    End Sub

'--------------------------------
' ウィンドウプロシージャ
'Protected
Public
    Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
        Dim h = Nothing As MessageHandler
        Dim b = messageMap.TryGetValue(Hex$(msg), h)
        If b Then
            If Not IsNothing(h) Then
                Dim a = New MessageArgs(hwnd, msg, wp, lp)
                h(This, a)
                If a.Handled Then
                    WndProc = a.LResult
                    Exit Function
                End If
            End If
        End If
        WndProc = DefWndProc(msg, wp, lp)
    End Function

    Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
        If prevWndProc Then
            DefWndProc = CallWindowProc(prevWndProc, hwnd, msg, wp, lp)
        Else
            DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
        End If
    End Function

Private
    Static Function makeKeysFormMsg(e As MessageArgs) As Keys
        Dim t As DWord
        t = e.WParam And Keys.KeyCode
        t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
        t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
        t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
        makeKeysFormMsg = t As Keys
    End Function

    Static Function makeMouseEventFromMsg(e As MessageArgs) As MouseArgs
        Dim wp = e.WParam
        Dim lp = e.LParam
        makeMouseEventFromMsg = New MouseArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
    End Function

Protected
    /*!
    @brief  最初にウィンドウプロシージャを使うための前処理を行う関数
    @date   2008/07/11
    WndProcFirstを使うときは、この関数を呼んでおく必要がある。
    */
    Sub StartWndProc()
        TlsSetValue(tlsIndex, ObjPtr(This))
        registerStandardEvent()
    End Sub
Private
    /*!
    @brief  主なメッセージハンドラの登録を行う関数
    @date   2008/08/02
    */
    Sub registerStandardEvent()
        AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
        Dim md = New MessageHandler(AddressOf(OnMouseDownBase))
        AddMessageEvent(WM_LBUTTONDOWN, md)
        AddMessageEvent(WM_RBUTTONDOWN, md)
        AddMessageEvent(WM_MBUTTONDOWN, md)
        AddMessageEvent(WM_XBUTTONDOWN, md)
        Dim mu = New MessageHandler(AddressOf(OnMouseUpBase))
        AddMessageEvent(WM_LBUTTONUP, mu)
        AddMessageEvent(WM_RBUTTONUP, mu)
        AddMessageEvent(WM_MBUTTONUP, mu)
        AddMessageEvent(WM_XBUTTONUP, mu)
        Dim mb = New MessageHandler(AddressOf(OnMouseDblClkBase))
        AddMessageEvent(WM_LBUTTONDBLCLK, mb)
        AddMessageEvent(WM_RBUTTONDBLCLK, mb)
        AddMessageEvent(WM_MBUTTONDBLCLK, mb)
        AddMessageEvent(WM_XBUTTONDBLCLK, mb)

        AddMessageEvent(WM_MOUSEMOVE, AddressOf(OnMouseMoveBase))
        AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase))
        AddMessageEvent(WM_MOUSEHOVER, AddressOf(OnMouseHoverBase))
        AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase))
        AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase))
        AddMessageEvent(WM_CHAR, AddressOf(OnChar)) 
        AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
        AddMessageEvent(WM_SIZE, AddressOf(OnSize))
    End Sub

    Sub OnEraseBackground(sender As Object, e As MessageArgs)
        Dim a = New PaintBackgroundArgs(e.WParam, e.LParam)
        e.Handled = e.Handled And OnPaintBackground(a)
        e.LResult = a.Painted
    End Sub

    Sub OnMouseDownBase(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnMouseDown(makeMouseEventFromMsg(e))
    End Sub

    Sub OnMouseUpBase(sender As Object, e As MessageArgs)
        Dim me = makeMouseEventFromMsg(e)
        If doubleClickFired = False Then
            OnClick(Args.Empty)
            OnMouseClick(me)
        Else
            doubleClickFired = False
        End If
        e.Handled = e.Handled And OnMouseUp(me)
    End Sub

    Sub OnMouseDblClkBase(sender As Object, e As MessageArgs)
        Dim me = makeMouseEventFromMsg(e)
        doubleClickFired = True
        OnMouseDown(me)
        OnDoubleClick(Args.Empty)
        e.Handled = e.Handled And OnMouseDoubleClick(me)
    End Sub

    Sub OnMouseMoveBase(sender As Object, e As MessageArgs)
        Dim me = makeMouseEventFromMsg(e)
        If mouseEntered = False Then
            mouseEntered = True
            OnMouseEnter(me)
            trackMouseEvent(TME_LEAVE Or TME_HOVER)
        End If
        e.Handled = e.Handled And OnMouseMove(me)
    End Sub

    Sub OnMouseLeaveBase(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnMouseLeave(Args.Empty)
        mouseEntered = False
    End Sub

    Sub OnMouseHoverBase(sender As Object, e As MessageArgs)
        Dim me = makeMouseEventFromMsg(e)
        e.Handled = e.Handled And OnMouseHover(me)
    End Sub

    Sub OnPaintBase(sender As Object, e As MessageArgs)
        If ActiveBasic.IsNothing(paintDC) Then
            e.Handled = False
        Else
            Dim ps As PAINTSTRUCT
            BeginPaint(ps)
            Try
                OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
            Finally
                EndPaint(ps)
            End Try
        End If
    End Sub

    Sub OnKeyDownBase(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
    End Sub

    Sub OnKeyUpBase(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
    End Sub

    Sub OnChar(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnKeyPress(New KeyPressArgs(e.WParam As Char))
    End Sub

    Sub OnCreateBase(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnCreate(New CreateArgs(e.LParam As *CREATESTRUCT))
    End Sub

    Sub OnSize(sender As Object, e As MessageArgs)
        e.Handled = e.Handled And OnResize(New ResizeArgs(e.WParam, e.LParam))
    End Sub

    messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageHandler>

Public
    /*!
    @biref  メッセージイベントハンドラを登録する。
    @date   2007/12/04
    */
    Sub AddMessageEvent(message As DWord, h As MessageHandler)
        If Not IsNothing(h) Then
            If IsNothing(messageMap) Then
                messageMap = New System.Collections.Generic.Dictionary<Object, MessageHandler>
            End If
            Dim msg = Hex$(message)
            Dim m = Nothing As MessageHandler
            If messageMap.TryGetValue(msg, m) Then
                messageMap.Item[msg] = m + h
            Else
                messageMap.Item[msg] = h
            End If
        End If
    End Sub

    /*!
    @biref  メッセージイベントハンドラ登録を解除する。
    @date   2007/12/04
    */
    Sub RemoveMessageEvent(message As DWord, a As MessageHandler)
        If Not IsNothing(a) Then
            If Not IsNothing(messageMap) Then
                Dim msg = Hex$(message)
                Dim m = messageMap.Item[msg]
                If Not IsNothing(m) Then
                    messageMap.Item[msg] = m - a
                End If
            End If
        End If
    End Sub

'--------------------------------
' ウィンドウメッセージ処理


'--------
'イベント

#include "ControlEvent.sbp"

'--------------------------------
' インスタンスメンバ変数
Private
    /*!
    @brief  サブクラス化前のウィンドウプロシージャ
    @date   2008/08/23
    サブクラス化していなければNULL
    */
    prevWndProc As WNDPROC
    /*!
    @brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
    外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
    */
    mouseEntered As Boolean
    /*!
    @brief ダブルクリックが起こったかどうかのフラグ
    Click/MouseClickイベントのために用意している。
    @date   2008/07/12
    */
    doubleClickFired As Boolean

'--------------------------------
' 初期ウィンドウクラス
Protected
    Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
        Imports System.Runtime.InteropServices

        Dim rThis = FromHWndCore(hwnd)
        If IsNothing(rThis) Then
            rThis = _System_PtrObj(TlsGetValue(tlsIndex)) As Control
            TlsSetValue(tlsIndex, 0)
            If IsNothing(rThis) Then
                Goto *InstanceIsNotFound
            End If
            ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
            rThis.AssociateHWnd(hwnd)
        End If
        If msg = WM_NCDESTROY Then
            rThis.UnassociateHWnd()
            rThis.hwnd = 0
        End If
        If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
            Dim f = rThis.finalDestroy
            f(rThis, Args.Empty)
        End If
        WndProcFirst = rThis.WndProc(msg, wp, lp)
        Exit Function

    *InstanceIsNotFound
        Dim err = String.Concat("Control.WndProcFirst: The attached instance is not found. msg = &h",
            Hex$(msg), Ex"\r\n")
        OutputDebugString(ToTCStr(err))
        WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
    End Function

    /*!
    @brief  Controlインスタンスとウィンドウハンドルを結び付ける。
    @param[in] hwndNew  結び付けるウィンドウハンドル
    @date   2008/07/16
    これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなると共に、
    FromHWndでウィンドウハンドルからControlインスタンスの取得が可能となる。
    */
    Sub AssociateHWnd(hwndNew As HWND)
        hwnd = hwndNew
        Prop[PropertyInstance] = ObjPtr(This) As HANDLE
        comImpl.AddRef()
    End Sub

    /*!
    @brief  オーナーの破棄時にこのControlインスタンスとウィンドウハンドルの結び付けを解除するよう登録する。
    @param[in] owner 結び付けの解除を連動させるControl
    @date   2008/07/16
    ownerのFinalDestoryでこのControlとHWNDとの結び付けを解除する。
    */
    Sub RegisterUnassociateHWnd(owner As Control)
        If IsNothing(owner) = False Then
            Dim e = New Handler(AddressOf(UnassociateHWndOnEvent))
            If IsNothing(finalDestroy) Then
                owner.finalDestroy = e
            Else
                owner.finalDestroy += e
            End If
        End If
    End Sub

    Sub UnassociateHWndOnEvent(sender As Object, e As Args)
        UnassociateHWnd()
        hwnd = 0
    End Sub

    Sub UnassociateHWnd()
        comImpl.Release()
    End Sub

'   Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
'   Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord

'--------------------------------
'   インタフェース実装

Public
    Virtual Function QueryInterfaceImpl(ByRef iid As IID, ByRef pv As VoidPtr) As HRESULT
        QueryInterfaceImpl = E_NOTIMPL
    End Function

Private
    /*!
    @brief ウィンドウの寿命管理
    Controlには次のAddRef-Releaseの対がある。
    @li createImpl - WM_NCDESTROY（ウィンドウプロシージャがWndProcFirstの場合）
    @li createImpl - UnassociateHWnd←UnassociateHWndOnEvent←RegisterUnassociateHWnd（その他のウィンドウクラスの場合）
    @li Attach - WM_NCDESTROY（サブクラス化された場合）
    なお、Control派生クラスをサブクラス化すると、後ろ2つが両方適用される。
    */
    comImpl As COM.ComClassDelegationImpl

'--------------------------------
'   その他の補助関数
Private
    Function trackMouseEvent(flags As DWord) As BOOL
        If pTrackMouseEvent <> 0 Then
            Dim tme As TRACKMOUSEEVENT
            With tme
                .cbSize = Len(tme)
                .dwFlags = flags
                .hwndTrack = hwnd
                .dwHoverTime = HOVER_DEFAULT
            End With
            trackMouseEvent = pTrackMouseEvent(tme)
        End If
    End Function

'--------------------------------
' 初期化終了関連（特にウィンドウクラス）
Private
    'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
    Static tlsIndex As DWord

    Static hInstance As HINSTANCE
    Static atom As ATOM
    Static hmodComctl As HMODULE
    Static pTrackMouseEvent As Detail.PTrackMouseEvent

    Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
    Static Const PropertyInstance = 0 As ATOM
Public
    Static Sub Initialize(hinst As HINSTANCE)
        tlsIndex = TlsAlloc()
        hInstance = hinst
        hmodComctl = LoadLibrary("comctl32.dll")
        pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent")) As Detail.PTrackMouseEvent

        Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
        PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))

        Dim wcx As WNDCLASSEX
        With wcx
            .cbSize = Len (wcx)
            .style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
            .lpfnWndProc = AddressOf (WndProcFirst)
            .cbClsExtra = 0
            .cbWndExtra = 0
            .hInstance = hinst
            .hIcon = 0
            .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
            .hbrBackground = 0
            .lpszMenuName = 0
            .lpszClassName = ToTCStr(WindowClassName)
            .hIconSm = 0
        End With
        atom = RegisterClassEx(wcx)
        If atom = 0 Then
            Dim buf[1023] As TCHAR
            wsprintf(buf, Ex"ActiveBasic.Windows.UI.Control.Control: RegisterClasseEx failed. Error code: &h%08X\r\n", GetLastError())
            OutputDebugString(buf)
            Debug
            ExitThread(0)
        End If
    End Sub

    Static Sub Uninitialize()
        If atom <> 0 Then
            UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
        End If
        If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
            TlsFree(tlsIndex)
        End If
        If hmodComctl <> 0 Then
            FreeLibrary(hmodComctl)
        End If
        If PropertyInstance <> 0 Then
            GlobalDeleteAtom(PropertyInstance)
        End If
    End Sub
End Class

End Namespace 'UI
End Namespace 'Widnows
End Namespace 'ActiveBasic