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

'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

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

    Virtual Sub ~Control()
    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

'--------------------------------
' ウィンドウ作成
'   Function Create(
'       parent As HWND,
'       rect As RECT,
'       name As String,
'       style As DWord,
'       exStyle = 0 As DWord,
'       menu = 0 As HMENU) As HWND

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)
        If hwnd <> 0 Then
            Throw New System.InvalidOperationException("Window already created.")
        End If

        StartWndProc()

        With cs
            'よそのウィンドウクラスの場合、WndProcFirst内のhwndの代入が行われないため、ここでも行っておく。
            hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
                .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
            If hwnd = 0 Then
                ActiveBasic.Windows.ThrowByWindowsError(GetLastError())
            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

'--------------------------------
' ウィンドウプロシージャ
'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)
                WndProc = a.LResult
                Exit Function
            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
        DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
    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)
        If IsNothing(paintBackground) Then
            Dim rc = ClientRect
            FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
        Else
            OnPaintBackground(New PaintBackgroundArgs(e.WParam, e.LParam))
        End If
        e.LResult = TRUE
    End Sub

    Sub OnMouseDownBase(sender As Object, e As MessageArgs)
        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
        OnMouseUp(me)
    End Sub

    Sub OnMouseDblClkBase(sender As Object, e As MessageArgs)
        Dim me = makeMouseEventFromMsg(e)
        doubleClickFired = True
        OnMouseDown(me)
        OnDoubleClick(Args.Empty)
        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
        OnMouseMove(me)
    End Sub

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

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

    Sub OnPaintBase(sender As Object, e As MessageArgs)
        Dim ps As PAINTSTRUCT
        BeginPaint(ps)
        Try
            OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
        Finally
            EndPaint(ps)
        End Try
    End Sub

    Sub OnKeyDownBase(sender As Object, e As MessageArgs)
        OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
    End Sub

    Sub OnKeyUpBase(sender As Object, e As MessageArgs)
        OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
    End Sub

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

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

    Sub OnSize(sender As Object, e As MessageArgs)
        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 マウスカーソルがクライアント領域に入っているかどうかのフラグ
    外から中に入ってきたときに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()
        End If
        If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
            Dim f = rThis.finalDestroy
            f(rThis, Args.Empty)
'           finalDestroy(This, Args.Empty)
        End If
        WndProcFirst = rThis.WndProc(msg, wp, lp)
        Exit Function

    *InstanceIsNotFound
        Dim err = "ActiveBasic.Windows.UI.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] hwnd 結び付けるウィンドウハンドル
    @date   2008/07/16
    これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなると共に、
    FromHWndでウィンドウハンドルからControlインスタンスの取得が可能となる。
    */
    Sub AssociateHWnd(hwnd As HWND)
        This.hwnd = hwnd
        This.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()
    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
    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