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

'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
Public
    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 IsWindow(hwnd) Then
            FromHWnd = FromHWndCore(hwnd)
        End If
    End Function

Private
    Static Function FromHWndCore(hwnd As HWND) As Control
        If GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
            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 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
    Function Create() As Boolean
        Dim cs As CREATESTRUCT
        cs.hInstance = hInstance
        cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
        GetCreateStruct(cs)
        Create = createImpl(cs)
    End Function

Protected
    Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

    Function createImpl(ByRef cs As CREATESTRUCT) As Boolean
        Imports System.Runtime.InteropServices

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

        StartWndProc()

        With cs
            Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
                .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
            createImpl = hwnd <> 0
        End With
    End Function

'--------------------------------
' ウィンドウプロシージャ
'Protected
Public
    Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
        Dim h = Nothing As MessageEventHandler
        Dim b = messageMap.TryGetValue(Hex$(msg), h)
        If b Then
            If Not IsNothing(h) Then
                Dim a = New MessageEventArgs(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 MessageEventArgs) 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 MessageEventArgs) As MouseEventArgs
        Dim wp = e.WParam
        Dim lp = e.LParam
        makeMouseEventFromMsg = New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
    End Function

    /*!
    @brief  最初にウィンドウプロシージャが呼ばれるときに実行される関数
    ここでは、主なメッセージハンドラの登録を行っている。
    @date   2008/07/11
    */
    Sub StartWndProc()
        Dim t = This '#177対策
        AddMessageEvent(WM_ERASEBKGND, AddressOf(t.OnEraseBackground))
        Dim md = New MessageEventHandler(AddressOf(t.OnMouseDownBase))
        AddMessageEvent(WM_LBUTTONDOWN, md)
        AddMessageEvent(WM_RBUTTONDOWN, md)
        AddMessageEvent(WM_MBUTTONDOWN, md)
        AddMessageEvent(WM_XBUTTONDOWN, md)
        Dim mu = New MessageEventHandler(AddressOf(t.OnMouseUpBase))
        AddMessageEvent(WM_LBUTTONUP, mu)
        AddMessageEvent(WM_RBUTTONUP, mu)
        AddMessageEvent(WM_MBUTTONUP, mu)
        AddMessageEvent(WM_XBUTTONUP, mu)
        Dim mb = New MessageEventHandler(AddressOf(t.OnMouseDblClkBase))
        AddMessageEvent(WM_LBUTTONDBLCLK, mu)
        AddMessageEvent(WM_RBUTTONDBLCLK, mu)
        AddMessageEvent(WM_MBUTTONDBLCLK, mu)
        AddMessageEvent(WM_XBUTTONDBLCLK, mu)

        AddMessageEvent(WM_MOUSELEAVE, AddressOf(t.OnMouseLeaveBase))
        AddMessageEvent(WM_PAINT, AddressOf(t.OnPaintBase))
        AddMessageEvent(WM_KEYDOWN, AddressOf(t.OnKeyDownBase))
'       AddMessageEvent(WM_CHAR, AddressOf(t.OnChar))   
        AddMessageEvent(WM_CREATE, AddressOf(t.OnCreateBase))
    End Sub

    Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
        Dim rc As RECT
        Dim r = GetClientRect(hwnd, rc)
        FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
        e.LResult = TRUE
    End Sub

    Sub OnMouseDownBase(sender As Object, e As MessageEventArgs)
        OnMouseDown(makeMouseEventFromMsg(e))
    End Sub

    Sub OnMouseUpBase(sender As Object, e As MessageEventArgs)
        Dim me = makeMouseEventFromMsg(e)
        If doubleClickFired = False Then
'           OnClick(System.EventArgs.Empty)
            OnMouseClick(me)
            doubleClickFired = False
        End If
        OnMouseUp(me)
    End Sub

    Sub OnMouseDblClkBase(sender As Object, e As MessageEventArgs)
        Dim me = makeMouseEventFromMsg(e)
        doubleClickFired = True
        OnMouseDown(me)
'       OnDoubleClick(System.EventArgs.Empty)
        OnMouseDoubleClick(me)
    End Sub

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

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

    Sub OnKeyDownBase(sender As Object, e As MessageEventArgs)
        OnKeyDown(New KeyEventArgs(makeKeysFormMsg(e)))
    End Sub

    Sub OnKeyUpBase(sender As Object, e As MessageEventArgs)
        OnKeyUp(New KeyEventArgs(makeKeysFormMsg(e)))
    End Sub

'   コメントアウト解除のときはStartWndProcのコメントアウト解除も忘れないこと
'   Sub OnChar(sender As Object, e As MessageEventArgs)
'       OnKeyPress(New KeyPressEventArgs(e.WParam As Char))
'   End Sub

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

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

Public
    /*!
    @biref  メッセージイベントハンドラを登録する。
    @date   2007/12/04
    */
    Sub AddMessageEvent(message As DWord, h As MessageEventHandler)
        If Not IsNothing(h) Then
            If IsNothing(messageMap) Then
                messageMap = New System.Collections.Generic.Dictionary<Object, MessageEventHandler>
            End If
            Dim msg = Hex$(message)
            Dim m = Nothing As MessageEventHandler
            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 MessageEventHandler)
        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
    hwnd As HWND
    /*!
    @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 = Control.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が呼ばれたとき

            If IsNothing(rThis) Then
                Goto *InstanceIsNotFound
            End If
            rThis.hwnd = hwnd
            SetProp(hwnd, PropertyInstance As ULONG_PTR As PCSTR, gchValue As HANDLE)
        End If
        WndProcFirst = rThis.WndProc(msg, wp, lp)
        If msg = WM_NCDESTROY Then
            Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
            If gchValue <> 0 Then
                Dim gch = GCHandle.FromIntPtr(gchValue)
                gch.Free()
            End If
        End If

        Exit Function

    *InstanceIsNotFound
        OutputDebugString("ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.")
        WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
    End Function

'   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

Class Form '仮
    Inherits Control
Protected
    Override Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
        With cs
            .lpCreateParams = 0
            '.hInstance
            .hMenu = 0
            .hwndParent = 0
            .cy = CW_USEDEFAULT
            .cx = CW_USEDEFAULT
            .y = CW_USEDEFAULT
            .x = CW_USEDEFAULT
            .style = WS_OVERLAPPEDWINDOW
            .lpszName = ""
            '.lpszClass
            .dwExStyle = 0
        End With
    End Sub
Public 

    Override Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
        WndProc = 0
        Select Case msg
            Case Else
                WndProc = Super.WndProc(msg, wp, lp)
        End Select
    End Function
End Class

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

'----------
'テスト実行用

Imports ActiveBasic.Windows.UI

'OleInitialize()
Control.Initialize(GetModuleHandle(0))

Class MyForm
    Inherits Form
Public
    Sub MyForm()
        Dim f = This
        f.AddMessageEvent(WM_DESTROY, AddressOf (f.Destory))
        f.AddPaintDC(AddressOf (f.Paint))
    End Sub

    Sub Destory(sender As Object, e As EventArgs)
        OutputDebugString(Ex"Destory\r\n")
        PostQuitMessage(0)
    End Sub

    Sub Paint(sender As Object, e As PaintDCEventArgs)
        TextOut(e.Handle, 10, 10, "Hello world!", 12)
    End Sub
End Class

Dim f = New MyForm
f.Create()
ShowWindow(f.Handle, SW_SHOW)

Dim m As MSG
Do
    Dim ret = GetMessage(m, 0, 0, 0)
    If ret = 0 Then
        Exit Do
    ElseIf ret = -1 Then
        ExitProcess(-1)
    End If

    TranslateMessage(m)
    DispatchMessage(m)
Loop

f = Nothing
System.GC.Collect()

Control.Uninitialize()
'OleUninitialize()

End