source: branch/egtra-gdiplus/Classes/System/Windows/Forms/Control.ab

' Classes/System/Windows/Forms/Control.ab

#ifndef __SYSTEM_WINDOWS_FORMS_CONTROL_AB__
#define __SYSTEM_WINDOWS_FORMS_CONTROL_AB__

#require <windows/WindowHandle.sbp>
#require <Classes/System/Windows/Forms/misc.ab>
#require <Classes/System/Windows/Forms/CreateParams.ab>
#require <Classes/System/Windows/Forms/Message.ab>
#require <Classes/System/Windows/Forms/PaintEventArgs.ab>
#require <Classes/System/misc.ab>
#require <Classes/System/Math.ab>
#require <Classes/System/Threading/WaitHandle.ab>
#require <Classes/System/Drawing/Color.ab>
#require <Classes/System/Drawing/Point.ab>
#require <Classes/System/Drawing/Size.ab>
#require <Classes/System/Drawing/Rectangle.ab>
#require <Classes/System/Runtime/InteropServices/GCHandle.ab>

TypeDef InvokeProc = *Function(p As VoidPtr) As VoidPtr

Class AsyncResultForInvoke
    Inherits IAsyncResult
Public
    ' Properties
    Sub AsyncResultForInvoke(h As HANDLE)
        waitHandle.Handle = h
    End Sub

    Override Function AsyncState() As Object
        Return Nothing
    End Function

    Override Function AsyncWaitHandle() As WaitHandle
        Return waitHandle
    End Function

    Override Function CompletedSynchronously() As Boolean
        Return FALSE
    End Function

    Override Function IsCompleted() As Boolean
        Return waitHandle.WaitOne(0, False)
    End Function

    Const Function Result() As VoidPtr
        Return result
    End Function

    Sub Result(r As VoidPtr)
        result = r
    End Sub

Private
    waitHandle As WaitHandle
    result As VoidPtr
End Class

Class AsyncInvokeData
Public
    FuncPtr As InvokeProc
    Data As *VoidPtr
    AsyncResult As AsyncResultForInvoke
End Class

Class Control
'   Inherits IWin32Window
Public
    '---------------------------------------------------------------------------
    ' Public Properties
    Function AllowDrop() As Boolean
    End Function

    /*Override*/ Function Handle() As HWND
        Return wnd.HWnd
    End Function

    ' IDropTargetを実装するのでDragAcceptFiles関数は呼ばない。
    Sub AllowDrop(a As Boolean)
    End Sub

    Const Function Visible() As Boolean
        Return wnd.Visible
    End Function

    Sub Visible(v As Boolean)
        wnd.Visible(v)
    End Sub

    Const Function Text() As String
        Return text
    End Function

    Sub Text(t As String)
        text = t
        Dim e As EventArgs
        OnTextChanged(e)
    End Sub

    Const Function Enabled() As Boolean
        Return wnd.Enabled
    End Function

    Sub Enabled(e As Boolean)
        ' OnEnabledChangedはWM_ENABLE経由で呼ばれる
        wnd.Enabled(e)
    End Sub

    Const Function Bounds() As Rectangle
        Dim wr As RECT
        wr = wnd.WindowRect
        Dim r = New Rectangle(wr)
        Dim parent = Parent
        If Object.ReferenceEquals(parent, Nothing) Then
            Return parent->RectangleToClient(r)
        Else
            Return r
        End If
    End Function

    Sub Bounds(r As Rectangle)
        SetBoundsCore(r.X, r.Y, r.Width, r.Height, BoundsSpecified.All)
    End Sub

    Const Function Location() As Point
        Return Bounds.Location
    End Function

    Sub Location(p As Point)
        SetBoundsCore(p.X, p.Y, 0, 0, BoundsSpecified.Location)
    End Sub

    Const Function Size() As Size
        Return Bounds.Size
    End Function

    Sub Size(s As Size)
        SetBoundsCore(0, 0, s.Width, s.Height, BoundsSpecified.Size)
    End Sub

    Const Function ClientRectangle() As Rectangle
        Return New Rectangle(wnd.ClientRect)
    End Function

    Const Function ClientSize() As Size
        Return ClientRectangle.Size
    End Function

    Const Function Left() As Long
        Dim b = Bounds
        Return b.Left
    End Function

    Sub Left(l As Long)
        SetBoundsCore(l, 0, 0, 0, BoundsSpecified.X)
    End Sub

    Const Function Top() As Long
        Dim b = Bounds
        Return b.Top
    End Function

    Sub Top(t As Long)
        SetBoundsCore(0, t, 0, 0, BoundsSpecified.Y)
    End Sub

    Const Function Width() As Long
        Dim b = Bounds
        Return b.Width
    End Function

    Sub Width(w As Long)
        SetBoundsCore(0, 0, w, 0, BoundsSpecified.Width)
    End Sub

    Const Function Height() As Long
        Dim b = Bounds
        Return b.Height
    End Function

    Sub Height(h As Long)
        SetBoundsCore(0, 0, 0, h, BoundsSpecified.Height)
    End Sub

    Const Function Right() As Long
        Dim b = Bounds
        Return b.Left + b.Width
    End Function

    Const Function Bottom() As Long
        Dim b = Bounds
        Return b.Top + b.Height
    End Function

    Const Function PointToScreen(p As Point) As Point
        PointToScreen = New Point
        ret.X = p.X
        ret.Y = p.Y
        wnd.ClientToScreen(ByVal VarPtr(PointToScreen) As *POINTAPI)
    End Function

    Const Function PointToClient(p As Point) As Point
        PointToScreen = New Point
        ret.X = p.X
        ret.Y = p.Y
        wnd.ScreenToClient(ByVal VarPtr(PointToScreen) As *POINTAPI)
    End Function

    Const Function RectangleToScreen(r As Rectangle) As Rectangle
        Dim rc = r.ToRECT
        wnd.ClientToScreen(rc)
        Return New Rectangle(rc)
    End Function

    Const Function RectangleToClient(r As Rectangle) As Rectangle
        Dim rc As RECT
        rc = r.ToRECT()
        wnd.ScreenToClient(rc)
        Return New Rectangle(rc)
    End Function

    Const Function InvokeRequired() As Boolean
        Return wnd.ThreadID <> GetCurrentThreadId()
    End Function

    Const Virtual Function BackColor() As Color
        Return bkColor
    End Function

    Virtual Sub BackColor(c As Color)
        c = bkColor
        Dim e As EventArgs
        OnBackColorChanged(e)
    End Sub

    Function Parent() As Control
        Return parent
    End Function

    Const Function IsHandleCreated() As Boolean
        Return wnd.HWnd <> 0
    End Function

    Static Function DefaultBackColor() As Color
        Return Color.FromArgb(255, 255, 255)
    End Function

    '---------------------------------------------------------------------------
    ' Constractors

    Sub Control()
        Dim sz = DefaultSize()
        Control("", 100, 100, sz.Width, sz.Height)
    End Sub

    Sub Control(text As String)
        Dim sz = DefaultSize()
        Control(text, 100, 100, sz.Width, sz.Height)
    End Sub

    Sub Control(parent As Control, text As String)
        Dim sz = DefaultSize()
        Control(parent, text, 100, 100, sz.Width, sz.Height)
    End Sub

    Sub Control(text As String, left As Long, top As Long, width As Long, height As Long)
        This.text = text
        bkColor = DefaultBackColor
    End Sub

    Sub Control(parent As Control, text As String, left As Long, top As Long, width As Long, height As Long)
        This.parent = VarPtr(parent)
        Control(text, left, top, width, height)
    End Sub

    '---------------------------------------------------------------------------
    ' Destractor

    Virtual Sub ~Control()
        If Not Object.ReferenceEquals(wnd, Nothing) Then
            If wnd.IsWindow Then
                wnd.Destroy() ' 暫定
            End If
        End If
    End Sub

    '---------------------------------------------------------------------------
    ' Public Methods

    ' 同期関数呼出、Controlが作成されたスレッドで関数を実行する。
    ' 関数は同期的に呼び出されるので、関数が終わるまでInvokeは制御を戻さない。
    Function Invoke(pfn As InvokeProc, p As VoidPtr) As VoidPtr
        Return wnd.SendMessage(WM_CONTROL_INVOKE, p As WPARAM, pfn As LPARAM) As VoidPtr
    End Function

    ' 非同期関数呼出、Controlが作成されたスレッドで関数を実行する。
    ' 関数は非同期的に呼び出されるので、BeginInvokeはすぐに制御を戻す。
    ' 後にEndInvokeを呼び出すことにより、関数の戻り値を受け取れる。
    Function BeginInvoke(pfn As InvokeProc, p As VoidPtr) As IAsyncResult
        ' EndInvokeがDeleteする
        Dim asyncResult = New AsyncResultForInvoke(CreateEvent(0, FALSE, FALSE, 0))
        ' OnControlBeginInvokeがDeleteする
        Dim asyncInvokeData = New AsyncInvokeData
        With asyncInvokeData
            .FuncPtr = pfn
            .Data = p
            .AsyncResult = asyncResult
        End With
        Dim gch = GCHandle.Alloc(asyncInvokeData)
        wnd.PostMessage(WM_CONTROL_BEGININVOKE, 0, GCHandle.ToIntPtr(gch))
        Return pAsyncResult
    End Function

    ' BeginInvokeで呼び出した関数の戻り値を受け取る。
    ' その関数がまだ終了していない場合、終了するまで待機する。
    Function EndInvoke(ar As IAsyncResult) As VoidPtr
        ar.WaitHandle.WaitOne()
        Dim arInvoke = ar As AsyncResultForInvoke
        Return arInvoke.Result
    End Function

    ' 与えられたウィンドウハンドルがControl（若しくはその派生クラス）の
    ' インスタンスに対応するものであった場合、
    ' 元のインスタンスを返す。
    ' そうでなければNothingを返す。
    Static Function FromHandle(hwnd As HWND) As Control
        If IsWindow(hwnd) Then
            If GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
                Dim gch = GCHandle.FromIntPtr(GetWindowLongPtr(hwnd, GWLP_THIS))
                Return gch.Target As Control
            End If
        End If
        Return Nothing As Control
    End Function

    Virtual Sub ResetText()
        text = ""
    End Sub

    Override Function ToString() As String
        Return text
    End Function

    ' Wrapper Methods
    Sub BringToFront()
        wnd.BringToTop()
    End Sub

    Sub Hide()
        wnd.Show(SW_HIDE)
    End Sub

    Sub Show()
        wnd.Show(SW_SHOW)
    End Sub

    Sub Update()
        wnd.Update()
    End Sub

    Sub CreateControl()
        CreateHandle() '暫定
    End Sub

Protected

    '---------------------------------------------------------------------------
    ' Protected Properties
'   Const Virtual Function CanRaiseEvents() As Boolean
    Virtual Function CreateParams() As CreateParams
        Return createParams
    End Function
'   Virtual Function DefaultCursor() As Cursor

    Virtual Function DefaultSize() As Size
        Dim s As Size(300, 300)
        Return s
    End Function

'   Function FontHeight() As Long
'   Sub FontHeight(h As Long)

'   Const Virtual Function Cursor() As Cursor
'   Virtual Sub Cursor(c As Cursor)

    '---------------------------------------------------------------------------
    ' Protected Methods
    Virtual Sub CreateHandle()
        Dim createParams = CreateParams()
        Dim gch = GCHandle.Alloc(This)
        TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)
        With createParams
            Dim hwndParent = 0 As HWND
            If Not Object.ReferenceEquals(parent, Nothing) Then
                hwndParent = parent.Handle
            End If
            Dim pText As PCTSTR
            If String.IsNullOrEmpty(text) Then
                pText = "" As PCTSTR
            Else
                pText = ToTCStr(text)
            End If

            If CreateWindowEx(.ExStyle, atom As ULONG_PTR As PCSTR, pText, .Style, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
                hwndParent, 0, hInstance, 0) = 0 Then
                ' Error
                Dim buf[1023] As TCHAR
                wsprintf(buf, ToTCStr(Ex"Control: CreateWindowEx failed. Error code: &h%08X\r\n"), GetLastError())
                OutputDebugString(buf)
'               Debug
                ExitThread(0)
            End If
        End With
        gch.Free()
    End Sub

    Virtual Sub DefWndProc(m As Message)
        m.Result = DefWindowProc(m.HWnd, m.Msg, m.WParam, m.LParam)
    End Sub

    Virtual Sub WndProc(m As Message)
        With m
            Select Case .Msg
                Case WM_GETTEXTLENGTH
                    .Result = text.Length
                Case WM_GETTEXT
                    Dim size = Math.Min(.WParam As ULONG_PTR, (text.Length + 1) As ULONG_PTR)
                    memcpy(.LParam As PCTSTR, ToTCStr(text), size * SizeOf (TCHAR))
                    .Result = size
                Case WM_SETTEXT
                    text = New String(.LParam As PCTSTR)
                Case WM_ENABLE
                    OnEnabledChanged(EventArgs.Empty)
                Case WM_ERASEBKGND
                    ' OnPaintBackgroundに移すべき
                    Dim hdc = .WParam As HDC
                    Dim hbr = CreateSolidBrush(bkColor.ToCOLORREF())
                    Dim hbrOld = SelectObject(hdc, hbr)
                    Dim rc = wnd.ClientRect
                    Rectangle(hdc, rc.left, rc.top, rc.right, rc.bottom)
                    SelectObject(hdc, hbrOld)
                    DeleteObject(hbr)
                Case WM_CONTROL_INVOKE
                    Dim pfn = .LParam As InvokeProc
                    .Result = pfn(m.WParam As VoidPtr) As LRESULT
                Case WM_CONTROL_BEGININVOKE
                    OnControlBeginInvoke(m)
                Case WM_CREATE
                    OnHandleCreated(EventArgs.Empty)
                Case WM_DESTROY
                    OnHandleDestroyed(EventArgs.Empty)
                Case Else
                    DefWndProc(m)
            End Select
        End With
    End Sub

    Virtual Sub SetClientSizeCore(x As Long, y As Long)
        Dim rc As RECT
        With rc
            .left = 0
            .top = 0
            .right = x
            .bottom = y
        End With
        Dim hasMenu = FALSE As BOOL
        If wnd.Parent As HWND = 0 Then
            If wnd.Menu <> 0 Then
                hasMenu = TRUE
            End If
        End If
        AdjustWindowRectEx(rc, wnd.Style, hasMenu, wnd.ExStyle)
        wnd.Move(rc)
    End Sub

    Virtual Sub SetBoundsCore(x As Long, y As Long, width As Long, height As Long, bs As BoundsSpecified)
'       If Not (bs As DWord And BoundsSpecified.X As DWord) Then
            x = Left
'       End If
'       If Not (bs As DWord And BoundsSpecified.Y As DWord) Then
            y = Right
'       End If
'       If Not (bs As DWord And BoundsSpecified.Width As DWord) Then
            width = Width
'       End If
'       If Not (bs As DWord And BoundsSpecified.Height As DWord) Then
            height = Height
'       End If
        wnd.Move(x, y, width, height)
    End Sub

    Virtual Sub NotifyInvalidate(r As Rectangle)
        Dim rc As RECT
        rc = r.ToRECT()
        wnd.InvalidateRect(rc)
    End Sub

    Virtual Sub OnPaintBackground(e As PaintEventArgs) : End Sub
    Virtual Sub OnEnabledChanged(e As EventArgs) : End Sub
    Virtual Sub OnBackColorChanged(e As EventArgs) : End Sub
    Virtual Sub OnHandleCreated(e As EventArgs) : End Sub
    Virtual Sub OnHandleDestroyed(e As EventArgs) : End Sub
    Virtual Sub OnTextChanged(e As EventArgs)
        wnd.SetText(ToTCStr(text))
    End Sub

Private
    ' Member variables
    wnd As WindowHandle
    text As String
    parent As Control
    bkColor As Color

    Static createParams As CreateParams

    'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
    Static tlsIndex As DWord

    Static hInstance As HINSTANCE
    Static atom As ATOM

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

    Static Const WindowClassName = "ActiveBasic Control"
Public
    Static Sub Initialize(hinst As HINSTANCE)
        tlsIndex = TlsAlloc()
        hInstance = hinst

        Dim wcx As WNDCLASSEX
        With wcx
            .cbSize = Len (wcx)
            .style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
            .lpfnWndProc = AddressOf (WndProcFirst)
            .cbClsExtra = 0
            .cbWndExtra = SizeOf (LONG_PTR) * 2
            .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, ToTCStr(Ex"Control: RegisterClasseEx failed. Error code: &h%08X\r\n"), GetLastError())
            OutputDebugString(buf)
            Debug
            ExitThread(0)
        End If

        With createParams
            ' 値は暫定的なもの
            .Style = WS_OVERLAPPEDWINDOW
            .ExStyle = WS_EX_APPWINDOW
        End With
    End Sub

    Static Sub Uninitialize()
        UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
        TlsFree(tlsIndex)
    End Sub
Private
    Static Const GWLP_THIS = SizeOf (LONG_PTR) * 0 As Long
    Static Const GWLP_TAG = SizeOf (LONG_PTR) * 1 As Long

    ' Windowsから呼ばれるウィンドウプロシージャ。WndProc
    Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
        Dim rThis = Control.FromHandle(hwnd) As Control
        If Object.ReferenceEquals(rThis As Object, Nothing) Then
            Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
            Dim gch = GCHandle.FromIntPtr(gchValue)
            rThis = gch.Target As Control
            ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
            If Object.ReferenceEquals(rThis, Nothing) Then
                ' あってはならない事態
                Debug
                ExitThread(-1)
            End If
            rThis.wnd = New WindowHandle(hwnd)
            SetWindowLongPtr(hwnd, GWLP_THIS, gchValue)
        End If

        Dim m = Message.Create(hwnd, msg, wp, lp)
        rThis.WndProc(m)
        Return m.Result
    End Function

    ' BeginInvokeが呼ばれたときの処理
    Sub OnControlBeginInvoke(m As Message)
        Dim gch = GCHandle.FromIntPtr(m.LParam)
        Dim data = gch.Target As AsyncInvokeData
        With data
            Dim pfn = .FuncPtr
            .AsyncResult.Result = pfn(.Data)
            SetEvent(.AsyncResult.AsyncWaitHandle.Handle)
        End With
    End Sub
End Class

Class _System_ControlIinitializer
Public
    Sub _System_ControlIinitializer(hinst As HINSTANCE)
        Control.Initialize(hinst)
    End Sub

    Sub ~_System_ControlIinitializer()
        Control.Uninitialize()
    End Sub
End Class

#ifndef _SYSTEM_NO_INITIALIZE_CONTROL_
Dim _System_ControlInitializer As _System_ControlIinitializer(GetModuleHandle(0))
#endif '_SYSTEM_NO_INITIALIZE_CONTROL_

#endif '__SYSTEM_WINDOWS_FORMS_CONTROL_AB__