Index: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Control.ab =================================================================== --- trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Control.ab (revision 563) +++ trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Control.ab (revision 564) @@ -7,7 +7,7 @@ Namespace UI -'Namespace Detail -' TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL -'End Namespace +Namespace Detail + TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL +End Namespace Class Control @@ -176,11 +176,12 @@ AddMessageEvent(WM_XBUTTONUP, mu) Dim mb = New MessageHandler(AddressOf(OnMouseDblClkBase)) - AddMessageEvent(WM_LBUTTONDBLCLK, mu) - AddMessageEvent(WM_RBUTTONDBLCLK, mu) - AddMessageEvent(WM_MBUTTONDBLCLK, mu) - AddMessageEvent(WM_XBUTTONDBLCLK, mu) + AddMessageEvent(WM_LBUTTONDBLCLK, mb) + AddMessageEvent(WM_RBUTTONDBLCLK, mb) + AddMessageEvent(WM_MBUTTONDBLCLK, mb) + AddMessageEvent(WM_XBUTTONDBLCLK, mb) AddMessageEvent(WM_MOUSEMOVE, AddressOf(OnMouseMoveBase)) AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase)) + AddMessageEvent(WM_MOUSEHOVER, AddressOf(OnMouseHoverBase)) AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase)) AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase)) @@ -191,6 +192,10 @@ Sub OnEraseBackground(sender As Object, e As MessageArgs) - Dim rc = ClientRect - FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH) + If IsNothing(paintBackground) Then + Dim rc = ClientRect + FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH) + Else + OnPaintBackground(New PaintBackgroundArgs(e.WParam, e.LParam)) + End If e.LResult = TRUE End Sub @@ -225,11 +230,16 @@ mouseEntered = True OnMouseEnter(me) + trackMouseEvent(TME_LEAVE Or TME_HOVER) End If End Sub Sub OnMouseLeaveBase(sender As Object, e As MessageArgs) + OnMouseLeave(Args.Empty) + mouseEntered = False + End Sub + + Sub OnMouseHoverBase(sender As Object, e As MessageArgs) Dim me = makeMouseEventFromMsg(e) - OnMouseLeave(me) - mouseEntered = False + OnMouseHover(me) End Sub @@ -415,16 +425,16 @@ ' その他の補助関数 Private -' Sub tracMouseEvent() -/* If pTrackMouseEvent <> 0 Then + Function trackMouseEvent(flags As DWord) As BOOL + If pTrackMouseEvent <> 0 Then Dim tme As TRACKMOUSEEVENT With tme .cbSize = Len(tme) - .dwFlags = TME_HOVER Or TME_LEAVE - .hwndTrack = wnd + .dwFlags = flags + .hwndTrack = hwnd .dwHoverTime = HOVER_DEFAULT End With - pTrackMouseEvent(tme) - End If -*/ 'End Sub + trackMouseEvent = pTrackMouseEvent(tme) + End If + End Function '-------------------------------- @@ -437,5 +447,5 @@ Static atom As ATOM Static hmodComctl As HMODULE -' Static pTrackMouseEvent As PTrackMouseEvent + Static pTrackMouseEvent As Detail.PTrackMouseEvent Static Const WindowClassName = "ActiveBasic.Windows.UI.Control" @@ -445,6 +455,6 @@ tlsIndex = TlsAlloc() hInstance = hinst -' hmodComctl = LoadLibrary("comctl32.dll") -' pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent")) + hmodComctl = LoadLibrary("comctl32.dll") + pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent")) As Detail.PTrackMouseEvent Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId()) @@ -483,7 +493,7 @@ TlsFree(tlsIndex) End If -' If hmodComctl <> 0 Then -' FreeLibrary(hmodComctl) -' End If + If hmodComctl <> 0 Then + FreeLibrary(hmodComctl) + End If If PropertyInstance <> 0 Then GlobalDeleteAtom(PropertyInstance) Index: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/ControlEvent.sbp =================================================================== --- trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/ControlEvent.sbp (revision 563) +++ trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/ControlEvent.sbp (revision 564) @@ -176,5 +176,5 @@ Public - Sub AddMouseLeave(h As MouseHandler) + Sub AddMouseLeave(h As Handler) If IsNothing(mouseLeave) Then mouseLeave = h @@ -183,5 +183,5 @@ End If End Sub - Sub RemoveMouseLeave(h As MouseHandler) + Sub RemoveMouseLeave(h As Handler) If Not IsNothing(mouseLeave) Then mouseLeave -= h @@ -189,5 +189,5 @@ End Sub Protected - Sub OnMouseLeave(e As MouseArgs) + Sub OnMouseLeave(e As Args) If Not IsNothing(mouseLeave) Then mouseLeave(This, e) @@ -195,5 +195,5 @@ End Sub Private - mouseLeave As MouseHandler + mouseLeave As Handler Public @@ -395,2 +395,24 @@ destroy As Handler +Public + Sub AddPaintBackground(h As PaintBackgroundHandler) + If IsNothing(paintBackground) Then + paintBackground = h + Else + paintBackground += h + End If + End Sub + Sub RemovePaintBackground(h As PaintBackgroundHandler) + If Not IsNothing(paintBackground) Then + paintBackground -= h + End If + End Sub +Protected + Sub OnPaintBackground(e As PaintBackgroundArgs) + If Not IsNothing(paintBackground) Then + paintBackground(This, e) + End If + End Sub +Private + paintBackground As PaintBackgroundHandler + Index: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/ControlEventList.txt =================================================================== --- trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/ControlEventList.txt (revision 563) +++ trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/ControlEventList.txt (revision 564) @@ -11,5 +11,5 @@ MouseMove Mouse マウスカーソルがコントロール上で移動すると呼び出されます MouseHover Mouse マウスカーソルがコントロール上で静止すると呼び出されます。 -MouseLeave Mouse マウスカーソルがコントロールから出て行くと呼び出されます。 +MouseLeave マウスカーソルがコントロールから出て行くと呼び出されます。 MouseDown Mouse マウスボタンが押されたときに呼び出されます。 MouseClick Mouse マウスでクリックされたときに呼び出されます。 @@ -22,2 +22,3 @@ Create Create ウィンドウが作成されたときに呼ばれます。 Destroy ウィンドウが破棄されるときに呼ばれます。 +PaintBackground PaintBackground 背景の描画を行うときに呼ばれます。 Index: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/EventArgs.ab =================================================================== --- trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/EventArgs.ab (revision 563) +++ trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/EventArgs.ab (revision 564) @@ -545,4 +545,24 @@ Delegate Sub ResizeHandler(sender As Object, e As ResizeArgs) +Class PaintBackgroundArgs + Inherits Args +Public + Sub PaintBackgroundArgs(hdc As HDC) + This.hdc = hdc + End Sub + + Sub PaintBackgroundArgs(wp As WPARAM, lp As LPARAM) + This.hdc = wp As HDC + End Sub + + Const Function Handle() As HDC + Handle = hdc + End Function +Private + hdc As HDC +End Class + +Delegate Sub PaintBackgroundHandler(sender As Object, e As PaintBackgroundArgs) + End Namespace 'UI End Namespace 'Widnows