Ignore:
Timestamp:
Jul 17, 2008, 11:20:10 PM (16 years ago)
Author:
イグトランス (egtra)
Message:

Buttonの追加。WM_COMMANDから子のClickイベントを発生させる仕組みの追加など。

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Control.ab

    r547 r551  
    1414    Inherits WindowHandle
    1515Public
     16    /*!
     17    @brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
     18    @date   2008/07/16
     19    */
     20    finalDestroy As ActiveBasic.Windows.UI.Handler
    1621
    1722    Sub Control()
    … …  
    3439Private
    3540    Static Function FromHWndCore(hwnd As HWND) As Control
    36         If _System_GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
    37             Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
    38             If gchValue <> 0 Then
    39                 Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
    40                 FromHWndCore = gch.Target As Control
    41                 Exit Function
    42             End If
     41        Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
     42        If gchValue <> 0 Then
     43            Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
     44            FromHWndCore = gch.Target As Control
     45            Exit Function
    4346        End If
    4447    End Function
    … …  
    5558
    5659Public
    57     Sub Create()
     60    Sub Create(parent = Nothing As Control, style = 0 As DWord, exStyle = 0 As DWord, hmenu = 0 As HMENU)
    5861        Dim cs As CREATESTRUCT
    59         cs.hInstance = hInstance
    60         cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
     62        With cs
     63            .dwExStyle = exStyle
     64            .lpszClass = (atom As ULONG_PTR) As LPCTSTR
     65            .lpszName = 0
     66            .style = style Or WS_CHILD Or WS_VISIBLE
     67            .x = CW_USEDEFAULT
     68            .y = CW_USEDEFAULT
     69            .cx = CW_USEDEFAULT
     70            .cy = CW_USEDEFAULT
     71            If IsNothing(parent) Then
     72                .hwndParent = 0
     73            Else
     74                .hwndParent = parent As HWND
     75                .style Or= WS_CHILD
     76            End If
     77            .hMenu = hmenu
     78            .hInstance = hInstance
     79        End With
    6180        GetCreateStruct(cs)
    62         createImpl(cs)
    63     End Sub
    64 
     81        createImpl(cs, parent)
     82    End Sub
     83
     84    Sub Create(parent As Control, style As DWord, exStyle As DWord, id As Long)
     85        Create(parent, style, exStyle, id As HMENU)
     86    End Sub
    6587Protected
    6688    Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
    6789
    68     Sub createImpl(ByRef cs As CREATESTRUCT)
     90    Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
    6991        Imports System.Runtime.InteropServices
    7092
    … …  
    7597
    7698        With cs
    77             Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
     99            'よそのクラスの場合、WndProcFirst内のhwndの代入が行われないため、ここでも行っておく。
     100            hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
    78101                .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
    79102            If hwnd = 0 Then
    80103                ActiveBasic.Windows.ThrowByWindowsError(GetLastError())
    81104            End If
     105           
     106            If IsNothing(FromHWndCore(hwnd)) <> False Then
     107                AssociateHWnd(gch, hwnd)
     108                TlsSetValue(tlsIndex, 0)
     109            End If
    82110        End With
     111
     112        If IsNothing(parent) = False Then
     113            RegisterUnassociateHWnd(parent)
     114        End If
    83115    End Sub
    84116
    … …  
    88120Public
    89121    Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
    90         Dim h = Nothing As MessageEventHandler
     122        Dim h = Nothing As MessageHandler
    91123        Dim b = messageMap.TryGetValue(Hex$(msg), h)
    92124        If b Then
    93125            If Not IsNothing(h) Then
    94                 Dim a = New MessageEventArgs(hwnd, msg, wp, lp)
     126                Dim a = New MessageArgs(hwnd, msg, wp, lp)
    95127                h(This, a)
    96128                WndProc = a.LResult
    … …  
    106138
    107139Private
    108     Static Function makeKeysFormMsg(e As MessageEventArgs) As Keys
     140    Static Function makeKeysFormMsg(e As MessageArgs) As Keys
    109141        Dim t As DWord
    110142        t = e.WParam And Keys.KeyCode
    … …  
    115147    End Function
    116148
    117     Static Function makeMouseEventFromMsg(e As MessageEventArgs) As MouseEventArgs
     149    Static Function makeMouseEventFromMsg(e As MessageArgs) As MouseArgs
    118150        Dim wp = e.WParam
    119151        Dim lp = e.LParam
    120         makeMouseEventFromMsg = New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
     152        makeMouseEventFromMsg = New MouseArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
    121153    End Function
    122154
    … …  
    128160    Sub StartWndProc()
    129161        AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
    130         Dim md = New MessageEventHandler(AddressOf(OnMouseDownBase))
     162        Dim md = New MessageHandler(AddressOf(OnMouseDownBase))
    131163        AddMessageEvent(WM_LBUTTONDOWN, md)
    132164        AddMessageEvent(WM_RBUTTONDOWN, md)
    133165        AddMessageEvent(WM_MBUTTONDOWN, md)
    134166        AddMessageEvent(WM_XBUTTONDOWN, md)
    135         Dim mu = New MessageEventHandler(AddressOf(OnMouseUpBase))
     167        Dim mu = New MessageHandler(AddressOf(OnMouseUpBase))
    136168        AddMessageEvent(WM_LBUTTONUP, mu)
    137169        AddMessageEvent(WM_RBUTTONUP, mu)
    138170        AddMessageEvent(WM_MBUTTONUP, mu)
    139171        AddMessageEvent(WM_XBUTTONUP, mu)
    140         Dim mb = New MessageEventHandler(AddressOf(OnMouseDblClkBase))
     172        Dim mb = New MessageHandler(AddressOf(OnMouseDblClkBase))
    141173        AddMessageEvent(WM_LBUTTONDBLCLK, mu)
    142174        AddMessageEvent(WM_RBUTTONDBLCLK, mu)
    … …  
    148180        AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase))
    149181        AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase))
    150 '       AddMessageEvent(WM_CHAR, AddressOf(OnChar))
     182        AddMessageEvent(WM_CHAR, AddressOf(OnChar))
    151183        AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
    152184    End Sub
    153185
    154     Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
     186    Sub OnEraseBackground(sender As Object, e As MessageArgs)
    155187        Dim rc = ClientRect
    156188        FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
    … …  
    158190    End Sub
    159191
    160     Sub OnMouseDownBase(sender As Object, e As MessageEventArgs)
     192    Sub OnMouseDownBase(sender As Object, e As MessageArgs)
    161193        OnMouseDown(makeMouseEventFromMsg(e))
    162194    End Sub
    163195
    164     Sub OnMouseUpBase(sender As Object, e As MessageEventArgs)
     196    Sub OnMouseUpBase(sender As Object, e As MessageArgs)
    165197        Dim me = makeMouseEventFromMsg(e)
    166198        If doubleClickFired = False Then
    167 '           OnClick(System.EventArgs.Empty)
     199'           OnClick(System.Args.Empty)
    168200            OnMouseClick(me)
    169201            doubleClickFired = False
    … …  
    172204    End Sub
    173205
    174     Sub OnMouseDblClkBase(sender As Object, e As MessageEventArgs)
     206    Sub OnMouseDblClkBase(sender As Object, e As MessageArgs)
    175207        Dim me = makeMouseEventFromMsg(e)
    176208        doubleClickFired = True
    177209        OnMouseDown(me)
    178 '       OnDoubleClick(System.EventArgs.Empty)
     210'       OnDoubleClick(System.Args.Empty)
    179211        OnMouseDoubleClick(me)
    180212    End Sub
    181213
    182     Sub OnMouseMoveBase(sender As Object, e As MessageEventArgs)
     214    Sub OnMouseMoveBase(sender As Object, e As MessageArgs)
    183215        Dim me = makeMouseEventFromMsg(e)
    184216        If mouseEntered Then
    … …  
    190222    End Sub
    191223
    192     Sub OnMouseLeaveBase(sender As Object, e As MessageEventArgs)
     224    Sub OnMouseLeaveBase(sender As Object, e As MessageArgs)
    193225        Dim me = makeMouseEventFromMsg(e)
    194226        OnMouseLeave(me)
    … …  
    196228    End Sub
    197229
    198     Sub OnPaintBase(sender As Object, e As MessageEventArgs)
     230    Sub OnPaintBase(sender As Object, e As MessageArgs)
    199231        Dim ps As PAINTSTRUCT
    200232        BeginPaint(ps)
    201233        Try
    202             OnPaintDC(New PaintDCEventArgs(ps.hdc, ps.rcPaint))
     234            OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
    203235        Finally
    204236            EndPaint(ps)
    … …  
    206238    End Sub
    207239
    208     Sub OnKeyDownBase(sender As Object, e As MessageEventArgs)
    209         OnKeyDown(New KeyEventArgs(makeKeysFormMsg(e)))
    210     End Sub
    211 
    212     Sub OnKeyUpBase(sender As Object, e As MessageEventArgs)
    213         OnKeyUp(New KeyEventArgs(makeKeysFormMsg(e)))
    214     End Sub
    215 
    216 '   コメントアウト解除のときはStartWndProcのコメントアウト解除も忘れないこと
    217 '   Sub OnChar(sender As Object, e As MessageEventArgs)
    218 '       OnKeyPress(New KeyPressEventArgs(e.WParam As Char))
    219 '   End Sub
    220 
    221     Sub OnCreateBase(sender As Object, e As MessageEventArgs)
    222         OnCreate(New CreateEventArgs(e.LParam As *CREATESTRUCT))
    223     End Sub
    224 
    225     messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageEventHandler>
     240    Sub OnKeyDownBase(sender As Object, e As MessageArgs)
     241        OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
     242    End Sub
     243
     244    Sub OnKeyUpBase(sender As Object, e As MessageArgs)
     245        OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
     246    End Sub
     247
     248    Sub OnChar(sender As Object, e As MessageArgs)
     249        OnKeyPress(New KeyPressArgs(e.WParam As Char))
     250    End Sub
     251
     252    Sub OnCreateBase(sender As Object, e As MessageArgs)
     253'       OnCreate(New CreateArgs(e.LParam As *CREATESTRUCT))
     254    End Sub
     255
     256    messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageHandler>
    226257
    227258Public
    … …  
    230261    @date   2007/12/04
    231262    */
    232     Sub AddMessageEvent(message As DWord, h As MessageEventHandler)
     263    Sub AddMessageEvent(message As DWord, h As MessageHandler)
    233264        If Not IsNothing(h) Then
    234265            If IsNothing(messageMap) Then
    235                 messageMap = New System.Collections.Generic.Dictionary<Object, MessageEventHandler>
     266                messageMap = New System.Collections.Generic.Dictionary<Object, MessageHandler>
    236267            End If
    237268            Dim msg = Hex$(message)
    238             Dim m = Nothing As MessageEventHandler
     269            Dim m = Nothing As MessageHandler
    239270            If messageMap.TryGetValue(msg, m) Then
    240271                messageMap.Item[msg] = m + h
    … …  
    249280    @date   2007/12/04
    250281    */
    251     Sub RemoveMessageEvent(message As DWord, a As MessageEventHandler)
     282    Sub RemoveMessageEvent(message As DWord, a As MessageHandler)
    252283        If Not IsNothing(a) Then
    253284            If Not IsNothing(messageMap) Then
    … …  
    302333            ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
    303334
    304             If IsNothing(rThis) Then
     335            If AssociateHWnd(gch, hwnd) = False Then
    305336                Goto *InstanceIsNotFound
    306337            End If
    307             rThis.hwnd = hwnd
    308             rThis.Prop[PropertyInstance] = gchValue As HANDLE
     338        End If
     339        If msg = WM_NCDESTROY Then
     340            rThis.UnassociateHWnd()
     341        End If
     342        If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
     343            Dim f = rThis.finalDestroy
     344            f(rThis, Args.Empty)
     345'           finalDestroy(This, Args.Empty)
    309346        End If
    310347        WndProcFirst = rThis.WndProc(msg, wp, lp)
    311         If msg = WM_NCDESTROY Then
    312             Dim gchValue = rThis.Prop(PropertyInstance) As ULONG_PTR
    313             If gchValue <> 0 Then
    314                 GCHandle.FromIntPtr(gchValue).Free()
    315             End If
    316         End If
    317 
    318348        Exit Function
    319349
    … …  
    322352        WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
    323353    End Function
     354
     355    /*!
     356    @brief  Controlインスタンスとウィンドウハンドルを結び付ける。
     357    @param[in] 結び付けられるControlインスタンスを格納したGCHandle
     358    @param[in] hwnd 結び付けるウィンドウハンドル
     359    @date   2008/07/16
     360    これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなる。
     361    */
     362    Static Function AssociateHWnd(gch As System.Runtime.InteropServices.GCHandle, hwnd As HWND) As Boolean
     363        Imports System.Runtime.InteropServices
     364        Dim rThis = gch.Target As Control
     365        If IsNothing(rThis) Then
     366            Exit Function
     367        End If
     368        rThis.hwnd = hwnd
     369        rThis.Prop[PropertyInstance] = GCHandle.ToIntPtr(gch) As HANDLE
     370    End Function
     371
     372    /*!
     373    @brief  オーナーの破棄時にこのControlインスタンスとウィンドウハンドルの結び付けを解除するよう登録する。
     374    @param[in] owner 結び付けの解除を連動させるControl
     375    @date   2008/07/16
     376    ownerのFinalDestoryでこのControlとHWNDとの結び付けを解除する。
     377    */
     378    Sub RegisterUnassociateHWnd(owner As Control)
     379        If IsNothing(owner) = False Then
     380            Dim e = New Handler(AddressOf(UnassociateHWndOnEvent))
     381            If IsNothing(finalDestroy) Then
     382                owner.finalDestroy = e
     383            Else
     384                owner.finalDestroy += e
     385            End If
     386        End If
     387    End Sub
     388
     389    Sub UnassociateHWndOnEvent(sender As Object, e As Args)
     390        UnassociateHWnd()
     391    End Sub
     392
     393    Sub UnassociateHWnd()
     394        Imports System.Runtime.InteropServices
     395        Dim gchValue = Prop(PropertyInstance) As ULONG_PTR
     396        If gchValue <> 0 Then
     397            GCHandle.FromIntPtr(gchValue).Free()
     398        End If
     399    End Sub
    324400
    325401'   Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
Note: See TracChangeset for help on using the changeset viewer.