source: Include/Classes/System/Windows/Forms/Control.ab@ 164

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

#ifndef __SYSTEM_WINDOWS_FORMS_CONTROL_AB__
#define __SYSTEM_WINDOWS_FORMS_CONTROL_AB__

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

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

    Override Function AsyncState() As *IObject
        Return 0
    End Function

    Override Function AsyncWaitHandle() As *WaitHandle
        Return VarPtr(AsyncWaitHandle)
    End Function

    Override Function CompletedSynchronously() As BOOL
        Return FALSE
    End Function

    Override Function IsCompleted() As BOOL
        Return AsyncWaitHandle()->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 *Function(p As VoidPtr) As VoidPtr
    Data As *VoidPtr
    AsyncResult As *AsyncResultForInvoke
End Class

Class Control
    Inherits IWin32Window
Public
    '---------------------------------------------------------------------------
    ' Public Properties

    Function AllowDrop() As BOOL
    End Function

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

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

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

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

    Const Function Text() As String
        Return text
    End Function

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

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

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

    Const Function Bounds() As Rectangle
        Dim wr As RECT
        wr = wnd.WindowRect
        Dim r As Rectangle(wr)
        Dim parent = Parent
        If parent <> 0 Then
            Return parent->RectangleToClient(r)
        Else
            Return r
        End If
    End Function

    Sub Bounds(ByRef 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
        Dim r As Rectangle(wnd.ClientRect)
        Return r
    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
        Return Left + Width
    End Function

    Const Function Bottom() As Long
        Return Top + Height
    End Function

    Const Function PointToScreen(p As Point) As Point
        wnd.ClientToScreen(ByVal VarPtr(p) As *POINTAPI)
        Return r
    End Function

    Const Function PointToClient(p As Point) As Point
        wnd.ScreenToClient(ByVal VarPtr(p) As *POINTAPI)
        Return r
    End Function

    Const Function RectangleToScreen(p As Rectangle) As Rectangle
        wnd.ClientToScreen(ByVal VarPtr(p) As *POINTAPI)
        Return p
    End Function

    Const Function RectangleToClient(p As Rectangle) As Rectangle
        wnd.ScreenToClient(ByVal VarPtr(p) As *POINTAPI)
        Return p
    End Function

    Const Function InvokeRequired() As BOOL
        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

    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(ByRef text As String)
        Dim sz = DefaultSize()
        Control(text, 100, 100, sz.Width, sz.Height)
    End Sub

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

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

    Sub Control(ByRef parent As Control, ByRef 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 wnd.IsWindow Then
            wnd.Destroy() ' 暫定
        End If
    End Sub

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

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

    ' 非同期関数呼出、Controlが作成されたスレッドで関数を実行する。
    ' 関数は非同期的に呼び出されるので、BeginInvokeはすぐに制御を戻す。
    ' 後にEndInvokeを呼び出すことにより、関数の戻り値を受け取れる。
    ' 注意：現状の実装では必ずEndInvokeを呼び出す必要がある。
    Function BeginInvoke(pfn As *Function(p As VoidPtr) As VoidPtr, p As VoidPtr) As *IAsyncResult
        ' EndInvokeがDeleteする
        Dim pAsyncResult = New AsyncResultForInvoke(CreateEvent(0, FALSE, FALSE, 0))
        ' OnControlBeginInvokeがDeleteする
        Dim pAsyncInvokeData = New AsyncInvokeData
        With pAsyncInvokeData[0]
            .FuncPtr = pfn
            .Data = p
            .AsyncResult = pAsyncResult
        End With
        wnd.PostMessage(WM_CONTROL_BEGININVOKE, 0, pAsyncInvokeData As LPARAM)
        Return pAsyncResult
    End Function

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

    ' 与えられたウィンドウハンドルがControl（若しくはその派生クラス）の
    ' インスタンスに対応するものであった場合、
    ' 元のインスタンスへのポインタを返す。
    ' そうでなければヌルポインタを返す。
    Static Function FromHandle(hwnd As HWND) As *Control
        If IsWindow(hwnd) Then
            Dim className[19] As Byte 'Len (WindowClassName)
            GetClassName(hwnd, className, Len (className))
            If memcmp(className, WindowClassName, Len (WindowClassName)) = 0 Then
                Return GetWindowLongPtr(hwnd, GWLP_THIS) As *Control
            End If
        End If
        Return 0 As *Control
    End Function

    Virtual Sub ResetText()
        text = ""
    End Sub

    /*Override*/ Virtual 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

Protected
    '---------------------------------------------------------------------------
    ' Protected Properties
'   Const Virtual Function CanRaiseEvents() As BOOL
    Virtual Function CreateParams() As *CreateParams
        Return VarPtr(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(ByRef c As Cursor)

    '---------------------------------------------------------------------------
    ' Protected Methods
    Virtual Sub CreateHandle()
        Dim createParams = CreateParams()
        TlsSetValue(tlsIndex, VarPtr(This))
        With createParams[0]
            Dim hwndParent = 0 As HWND
            If parent <> 0 Then
                hwndParent = parent->Handle
            End If
            If CreateWindowEx(.ExStyle, atom As ULONG_PTR As PCSTR, text, .Style, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
                hwndParent, 0, hInstance, 0) = 0 Then
                ' Error
                Dim buf[1023] As Byte
                wsprintf(buf, Ex"Control: CreateWindowEx failed. Error code: &h%08X\r\n", GetLastError())
                OutputDebugString(buf)
'               Debug
                ExitThread(0)
            End If
        End With
    End Sub

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

    Virtual Sub WndProc(ByRef 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 As ULONG_PTR + 1)
                    memcpy(.LParam As *Byte, text.StrPtr, size)
                    .Result = size
                Case WM_SETTEXT
                    text = .LParam As *Byte
                Case WM_ENABLE
                    Dim e As EventArgs
                    OnEnabledChanged(e)
                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 As *Function(p As VoidPtr) As VoidPtr
                    pfn = .LParam As *Function(p As VoidPtr) As VoidPtr
                    .Result = pfn(m.WParam As VoidPtr) As LRESULT
                Case WM_CONTROL_BEGININVOKE
                    OnControlBeginInvoke(m)
                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(ByRef e As PaintEventArgs) : End Sub
    Virtual Sub OnEnabledChanged(ByRef e As EventArgs) : End Sub
    Virtual Sub OnBackColorChanged(ByRef e As EventArgs) : End Sub
    Virtual Sub OnTextChanged(ByRef e As EventArgs)
        wnd.SetText(text.StrPtr)
    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" As *Byte
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 = WindowClassName
            .hIconSm = 0
        End With
        atom = RegisterClassEx(wcx)
        If atom = 0 Then
            Dim buf[1023] As Byte
            wsprintf(buf, 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 pThis = Control.FromHandle(hwnd) As *Control
        If pThis = 0 Then
            pThis = TlsGetValue(tlsIndex)
            ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
            TlsSetValue(tlsIndex, 0)
            If pThis = 0 Then
                ' あってはならない事態
                Debug
                ExitThread(0)
            End If
'           Debug
            pThis->wnd = hwnd
            SetWindowLongPtr(hwnd, GWLP_THIS, pThis As LONG_PTR)
        End If
        Dim m As Message
        m = Message.Create(hwnd, msg, wp, lp)
        pThis->WndProc(m)
        Return m.Result
    End Function

    ' BeginInvokeが呼ばれたときの処理
    Sub OnControlBeginInvoke(ByRef m As Message)
        Dim data As *AsyncInvokeData
        data = m.LParam As *AsyncInvokeData
        Dim asyncResult As *AsyncResultForInvoke
        asyncResult->Result = data->FuncPtr(data->Data)
        Dim wh = asyncResult->AsyncWaitHandle
        SetEvent(wh->Handle)
        Delete data
    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__