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

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

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

Namespace ActiveBasic
Namespace Windows
Namespace UI

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

Class Control
    Inherits WindowHandle
Public
    /*!
    @brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
    @date   2008/07/16
    */
    finalDestroy As ActiveBasic.Windows.UI.Handler

    Sub Control()
    End Sub

    Virtual Sub ~Control()
    End Sub

    Function Handle() As HWND
        Handle = hwnd
    End Function

    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
        Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
        If gchValue <> 0 Then
            Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
            FromHWndCore = gch.Target As Control
            Exit Function
        End If
    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
    Sub Create(parent = Nothing As Control, style = 0 As DWord, exStyle = 0 As DWord, hmenu = 0 As HMENU)
        Dim cs As CREATESTRUCT
        With cs
            .dwExStyle = exStyle
            .lpszClass = (atom As ULONG_PTR) As LPCTSTR
            .lpszName = 0
            .style = style Or WS_CHILD Or WS_VISIBLE
            .x = 0
            .y = 0
            .cx = 0
            .cy = 0
            If IsNothing(parent) Then
                .hwndParent = 0
            Else
                .hwndParent = parent As HWND
                .style Or= WS_CHILD
            End If
            .hMenu = hmenu
            .hInstance = hInstance
        End With
        GetCreateStruct(cs)
        createImpl(cs, parent)
    End Sub

    Sub Create(parent As Control, style As DWord, exStyle As DWord, id As Long)
        Create(parent, style, exStyle, id As HMENU)
    End Sub
Protected
    Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

    Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
        Imports System.Runtime.InteropServices

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

        Dim gch = GCHandle.Alloc(This)
        TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)

        StartWndProc()

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

    /*!
    @brief  最初にウィンドウプロシージャが呼ばれるときに実行される関数
    ここでは、主なメッセージハンドラの登録を行っている。
    @date   2008/07/11
    */
    Sub StartWndProc()
        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, mu)
        AddMessageEvent(WM_RBUTTONDBLCLK, mu)
        AddMessageEvent(WM_MBUTTONDBLCLK, mu)
        AddMessageEvent(WM_XBUTTONDBLCLK, mu)

        AddMessageEvent(WM_MOUSEMOVE, AddressOf(OnMouseMoveBase))
        AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase))
        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 rc = ClientRect
        FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
        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)
            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 Then
            OnMouseMove(me)
        Else
            mouseEntered = True
            OnMouseEnter(me)
        End If
    End Sub

    Sub OnMouseLeaveBase(sender As Object, e As MessageArgs)
        Dim me = makeMouseEventFromMsg(e)
        OnMouseLeave(me)
        mouseEntered = False
    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

'--------------------------------
' 初期ウィンドウクラス
Private
    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
            Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
            TlsSetValue(tlsIndex, 0)
            If gchValue = 0 Then
                Goto *InstanceIsNotFound
            End If
            Dim gch = GCHandle.FromIntPtr(gchValue)
            rThis = gch.Target As Control
            ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき

            AssociateHWnd(gch, 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] 結び付けられるControlインスタンスを格納したGCHandle
    @param[in] hwnd 結び付けるウィンドウハンドル
    @date   2008/07/16
    これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなる。
    */
    Static Sub AssociateHWnd(gch As System.Runtime.InteropServices.GCHandle, hwnd As HWND)
        Imports System.Runtime.InteropServices
        Dim rThis = gch.Target As Control
        If IsNothing(rThis) Then
            Exit Sub
        End If
        rThis.hwnd = hwnd
        rThis.Prop[PropertyInstance] = GCHandle.ToIntPtr(gch) As HANDLE
    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()
        Imports System.Runtime.InteropServices
        Dim gchValue = Prop(PropertyInstance) As ULONG_PTR
        If gchValue <> 0 Then
            GCHandle.FromIntPtr(gchValue).Free()
        End If
    End Sub

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

'--------------------------------
'   その他の補助関数
Private
'   Sub tracMouseEvent()
/*      If pTrackMouseEvent <> 0 Then
            Dim tme As TRACKMOUSEEVENT
            With tme
                .cbSize = Len(tme)
                .dwFlags = TME_HOVER Or TME_LEAVE
                .hwndTrack = wnd
                .dwHoverTime = HOVER_DEFAULT
            End With
            pTrackMouseEvent(tme)
        End If
*/  'End Sub

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

    Static hInstance As HINSTANCE
    Static atom As ATOM
    Static hmodComctl As HMODULE
'   Static pTrackMouseEvent As 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"))

        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