Ignore:
Timestamp:
Jul 13, 2008, 2:29:17 AM (16 years ago)
Author:
イグトランス (egtra)
Message:

Controlをデリゲートベースにした。DictionaryのContainsKeyとTryGetValueを実装。デリゲートの追加・削除の右辺にNothingを指定可能にした。

File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r473 r542  
    88Namespace Forms
    99
     10'Namespace Detail
     11'   TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
     12'End Namespace
     13
    1014Class Control
    1115Public
    … …  
    1923    End Sub
    2024
    21     Function Handle() As WindowHandle
    22         Handle = wnd
     25    Function Handle() As HWND
     26        Handle = hwnd
    2327    End Function
    2428
    … …  
    5357        menu = 0 As HMENU) As HWND
    5458*/
     59
    5560Public
    5661    Function Create() As Boolean
    … …  
    7176        TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)
    7277
     78        StartWndProc()
     79
    7380        With cs
    7481            Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
    … …  
    8390Public
    8491    Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
     92/*
    8593        Select Case msg
    86             Case WM_ERASEBKGND
    87                 Dim rc = wnd.ClientRect
    88                 Dim e = New PaintDCHandledEventArgs(wp As HDC, rc)
    89                 OnPaintBackground(e)
    90                 WndProc = e.Handled
    91             Case WM_PAINT
    92                 Dim ps As PAINTSTRUCT
    93                 wnd.BeginPaint(ps)
    94                 Try
    95                     Dim e = New PaintDCEventArgs(ps.hdc, ps.rcPaint)
    96                     OnPaintDC(e)
    97                 Finally
    98                     wnd.EndPaint(ps)
    99                 End Try
    100             Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN, WM_XBUTTONDOWN
    101                 OnMouseDown(New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0))
    102             Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP, WM_XBUTTONUP
    103                 OnMouseUp(New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0))
    104 /*
     94            Case WM_MOUSELEAVE
     95                OnMouseLeave(makeMouseEventFromWPLP(wp, lp))
     96                mouseEntered = False
    10597            Case WM_KEYDOWN
    10698                OnKeyDown(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
    … …  
    108100                OnKeyUp(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
    109101            Case WM_CHAR
    110                 OnKeyPress(New KeyPressEventArgs(wParam As Char))
    111             Case WM_ENABLE
    112                 OnEnableChanged(EventArgs.Empty)
    113             Case WM_MOVE
    114                 OnMove(EventArgs.Empty)
    115             Case WM_SIZE
    116                 OnResize(EventArgs.Empty)
     102                OnKeyPress(New KeyPressEventArgs(wp As Char))
     103'           Case WM_CREATE
     104            Case WM_DESTROY
     105                OnDestroy(EventArgs.Empty)
     106            Case Else
     107                WndProc = DefWndProc(msg, wp, lp)
     108        End Select
    117109*/
    118             Case Else
    119             WndProc = DefWndProc(msg, wp, lp)
    120         End Select
     110        Dim h = Nothing As MessageEventHandler
     111        Dim b = messageMap.TryGetValue(Hex$(msg), h)
     112        If b Then
     113            If Not IsNothing(h) Then
     114                Dim a = New MessageEventArgs(hwnd, msg, wp, lp)
     115                h(This, a)
     116                WndProc = a.LResult
     117                Exit Function
     118            End If
     119        End If
     120        WndProc = DefWndProc(msg, wp, lp)
    121121    End Function
    122122
    123123    Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
    124         DefWndProc = DefWindowProc(wnd.HWnd, msg, wp, lp)
    125     End Function
    126 
    127 Private
    128     Function makeKeysFormWPLP(wp As WPARAM, lp As LPARAM) As Keys
     124        DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
     125    End Function
     126
     127Private
     128    Static Function makeKeysFormWPLP(wp As WPARAM, lp As LPARAM) As Keys
    129129        Dim t As DWord
    130130        t = wp And Keys.KeyCode
    … …  
    135135    End Function
    136136
    137 
    138 '--------------------------------
    139 ' ウィンドウメッセージ処理
    140 
    141 '--------
    142 ' 2
    143 
    144 Protected
     137    Static Function makeMouseEventFromWPLP(wp As WPARAM, lp As LPARAM) As MouseEventArgs
     138        makeMouseEventFromWPLP = New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
     139    End Function
     140
    145141    /*!
    146     @biref  ウィンドウの背景を描画する。
     142    @brief  最初にウィンドウプロシージャが呼ばれるときに実行される関数
     143    ここでは、主なメッセージハンドラの登録を行っている。
     144    @date   2008/07/11
     145    */
     146    Sub StartWndProc()
     147        Dim t = This '#177対策
     148        messageMap = New System.Collections.Generic.Dictionary<Object, MessageEventHandler>
     149        AddMessageEvent(WM_ERASEBKGND, AddressOf(t.OnEraseBackground))
     150        Dim md = New MessageEventHandler(AddressOf(t.OnMouseDownBase))
     151        AddMessageEvent(WM_LBUTTONDOWN, md)
     152        AddMessageEvent(WM_RBUTTONDOWN, md)
     153        AddMessageEvent(WM_MBUTTONDOWN, md)
     154        AddMessageEvent(WM_XBUTTONDOWN, md)
     155        Dim mu = New MessageEventHandler(AddressOf(t.OnMouseUpBase))
     156        AddMessageEvent(WM_LBUTTONUP, mu)
     157        AddMessageEvent(WM_RBUTTONUP, mu)
     158        AddMessageEvent(WM_MBUTTONUP, mu)
     159        AddMessageEvent(WM_XBUTTONUP, mu)
     160        Dim mb = New MessageEventHandler(AddressOf(t.OnMouseDblClkBase))
     161        AddMessageEvent(WM_LBUTTONDBLCLK, mu)
     162        AddMessageEvent(WM_RBUTTONDBLCLK, mu)
     163        AddMessageEvent(WM_MBUTTONDBLCLK, mu)
     164        AddMessageEvent(WM_XBUTTONDBLCLK, mu)
     165        AddMessageEvent(WM_PAINT, AddressOf(t.OnPaintBase))
     166    End Sub
     167
     168    Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
     169        Dim rc As RECT
     170        Dim r = GetClientRect(hwnd, rc)
     171        FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
     172        e.LResult = TRUE
     173    End Sub
     174
     175    Sub OnMouseDownBase(sender As Object, e As MessageEventArgs)
     176        OnMouseDown(makeMouseEventFromWPLP(e.WParam, e.LParam))
     177    End Sub
     178
     179    Sub OnMouseUpBase(sender As Object, e As MessageEventArgs)
     180        Dim me = makeMouseEventFromWPLP(e.WParam, e.LParam)
     181        If doubleClickFired = False Then
     182            OnClick(EventArgs.Empty)
     183            OnMouseClick(me)
     184            doubleClickFired = False
     185        End If
     186        OnMouseUp(me)
     187    End Sub
     188
     189    Sub OnMouseDblClkBase(sender As Object, e As MessageEventArgs)
     190        Dim me = makeMouseEventFromWPLP(e.WParam, e.LParam)
     191        doubleClickFired = True
     192        OnMouseDown(me)
     193        OnDoubleClick(EventArgs.Empty)
     194        OnMouseDoubleClick(me)
     195    End Sub
     196
     197    Sub OnMouseMoveBase(sender As Object, e As MessageEventArgs)
     198        Dim me = makeMouseEventFromWPLP(e.WParam, e.LParam)
     199        If mouseEntered Then
     200            OnMouseMove(me)
     201        Else
     202            mouseEntered = True
     203            OnMouseEnter(me)
     204        End If
     205    End Sub
     206
     207    Sub OnPaintBase(sender As Object, e As MessageEventArgs)
     208        Dim ps As PAINTSTRUCT
     209        BeginPaint(hwnd, ps)
     210'       Try
     211'           OnPaintDC(New PaintDCEventArgs(ps.hdc, ps.rcPaint))
     212'       Finally
     213            EndPaint(hwnd, ps)
     214'       End Try
     215    End Sub
     216
     217
     218    messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageEventHandler>
     219
     220Public
     221    /*!
     222    @biref  メッセージイベントハンドラを登録する。
    147223    @date   2007/12/04
    148224    */
    149     Virtual Sub OnPaintBackground(e As PaintDCBackGroundEventArgs)
    150         Dim hbr = (COLOR_3DFACE + 1) As HBRUSH
    151         FillRect(e.Handle, e.ClipRect, hbr)
    152         e.Handled = True
    153     End Sub
     225    Sub AddMessageEvent(message As DWord, h As MessageEventHandler)
     226        If Not IsNothing(h) Then
     227            If IsNothing(messageMap) Then
     228                messageMap = New System.Collections.Generic.Dictionary<Object, MessageEventHandler>
     229            End If
     230            Dim msg = Hex$(message)
     231            Dim m = Nothing As MessageEventHandler
     232            If messageMap.TryGetValue(msg, m) Then
     233                messageMap.Item[msg] = m + h
     234            Else
     235                messageMap.Item[msg] = h
     236            End If
     237        End If
     238    End Sub
     239
     240    /*!
     241    @biref  メッセージイベントハンドラ登録を解除する。
     242    @date   2007/12/04
     243    */
     244    Sub RemoveMessageEvent(message As DWord, a As MessageEventHandler)
     245        If Not IsNothing(a) Then
     246            If Not IsNothing(messageMap) Then
     247                Dim msg = Nothing As Object : msg = New System.UInt32(message)
     248                Dim m = messageMap.Item[msg]
     249                If Not IsNothing(m) Then
     250                    messageMap.Item[msg] = m - a
     251                End If
     252            End If
     253        End If
     254    End Sub
     255
     256'--------------------------------
     257' ウィンドウメッセージ処理
     258
    154259
    155260'--------
    … …  
    162267' 1 インスタンスメンバ変数
    163268Private
    164     wnd As WindowHandle
     269    hwnd As HWND
     270    /*!
     271    @brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
     272    外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
     273    */
     274    mouseEntered As Boolean
     275    /*!
     276    @brief ダブルクリックが起こったかどうかのフラグ
     277    Click/MouseClickイベントのために用意している。
     278    @date   2008/07/12
     279    */
     280    doubleClickFired As Boolean
    165281
    166282'--------------------------------
    … …  
    184300                Goto *InstanceIsNotFound
    185301            End If
    186             rThis.wnd = New WindowHandle(hwnd)
    187             rThis.wnd.SetProp(PropertyInstance, gchValue As HANDLE)
     302            rThis.hwnd = hwnd
     303            SetProp(hwnd, PropertyInstance As ULONG_PTR As PCSTR, gchValue As HANDLE)
    188304        End If
    189305        WndProcFirst = rThis.WndProc(msg, wp, lp)
    … …  
    202318        WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
    203319    End Function
    204    
     320
    205321'   Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
    206322'   Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord
    207323
    208324'--------------------------------
     325'   その他の補助関数
     326Private
     327'   Sub tracMouseEvent()
     328/*      If pTrackMouseEvent <> 0 Then
     329            Dim tme As TRACKMOUSEEVENT
     330            With tme
     331                .cbSize = Len(tme)
     332                .dwFlags = TME_HOVER Or TME_LEAVE
     333                .hwndTrack = wnd
     334                .dwHoverTime = HOVER_DEFAULT
     335            End With
     336            pTrackMouseEvent(tme)
     337        End If
     338*/  'End Sub
     339
     340'--------------------------------
    209341' 1 初期化終了関連（特にウィンドウクラス）
    210 
     342Private
    211343    'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
    212344    Static tlsIndex As DWord
    … …  
    214346    Static hInstance As HINSTANCE
    215347    Static atom As ATOM
     348    Static hmodComctl As HMODULE
     349'   Static pTrackMouseEvent As PTrackMouseEvent
    216350
    217351    Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
    … …  
    221355        tlsIndex = TlsAlloc()
    222356        hInstance = hinst
     357'       hmodComctl = LoadLibrary("comctl32.dll")
     358'       pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent"))
    223359
    224360        Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
    … …  
    251387
    252388    Static Sub Uninitialize()
    253         UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
    254         TlsFree(tlsIndex)
    255         GlobalDeleteAtom(PropertyInstance)
    256     End Sub
     389        If atom <> 0 Then
     390            UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
     391        End If
     392        If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
     393            TlsFree(tlsIndex)
     394        End If
     395'       If hmodComctl <> 0 Then
     396'           FreeLibrary(hmodComctl)
     397'       End If
     398        If PropertyInstance <> 0 Then
     399            GlobalDeleteAtom(PropertyInstance)
     400        End If
     401    End Sub
     402
    257403End Class
    258404
    259 Namespace Detail
    260 Class _System_ControlIinitializer
    261 Public
    262     Sub _System_ControlIinitializer(hinst As HINSTANCE)
    263         Control.Initialize(hinst)
    264     End Sub
    265 
    266     Sub ~_System_ControlIinitializer()
    267         Control.Uninitialize()
    268     End Sub
    269 End Class
    270 
    271 #ifndef _SYSTEM_NO_INITIALIZE_CONTROL_
    272 Dim _System_ControlInitializer As _System_ControlIinitializer(GetModuleHandle(0))
    273 #endif '_SYSTEM_NO_INITIALIZE_CONTROL_
    274 
    275 End Namespace 'Detail
    276 
    277 Class Form
     405Class Form '仮
    278406    Inherits Control
    279407Protected
    … …  
    294422        End With
    295423    End Sub
    296 Public '仮
     424Public
     425
    297426    Override Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
    298427        WndProc = 0
    299428        Select Case msg
    300             Case WM_DESTROY
    301                 PostQuitMessage(0)
    302429            Case Else
    303430                WndProc = Super.WndProc(msg, wp, lp)
    … …  
    311438End Namespace 'ActiveBasic
    312439
     440
    313441'----------
    314442'テスト実行用
    … …  
    316444Imports ActiveBasic.Windows.UI.Forms
    317445
    318 Class Bar
    319 Public
    320 Static Sub PaintDCEvent(sender As Object, et As PaintDCEventArgs)
    321     Dim e = et As PaintDCEventArgs
    322     TextOut(e.Handle, 10, 10, "Hello, world", 12)
    323 End Sub
     446'OleInitialize()
     447Control.Initialize(GetModuleHandle(0))
     448
     449Class MyForm
     450    Inherits Form
     451Public
     452    Sub NcDestory(sender As Object, et As EventArgs)
     453        PostQuitMessage(0)
     454    End Sub
    324455End Class
    325456
    326 Dim f = New Form
     457Dim f = New MyForm
    327458f.Create()
    328 Dim v = New PaintDCEventHandler(AddressOf (Bar.PaintDCEvent))
    329 f.AddPaintDC(v)
    330 f.Handle.Show(SW_SHOW)
    331 
    332 MessageBox(0, "hello", "", 0)
     459Dim h = New MessageEventHandler(AddressOf (f.NcDestory))
     460f.AddMessageEvent(WM_NCDESTROY, h)
     461ShowWindow(f.Handle, SW_SHOW)
     462
     463Dim m As MSG
     464Do
     465    Dim ret = GetMessage(m, 0, 0, 0)
     466    If ret = 0 Then
     467        Exit Do
     468    ElseIf ret = -1 Then
     469        ExitProcess(-1)
     470    End If
     471
     472    TranslateMessage(m)
     473    DispatchMessage(m)
     474Loop
     475
     476f = Nothing
     477System.GC.Collect()
     478
     479Control.Uninitialize()
     480'OleUninitialize()
     481
     482End
     483
Note: See TracChangeset for help on using the changeset viewer.