'Classes/ActiveBasic/Windows/UI/Control.ab

#require <Classes/ActiveBasic/Windows/UI/EventArgs.ab>
#require <Classes/ActiveBasic/COM/ComClassBase.ab>

Namespace ActiveBasic
Namespace Windows
Namespace UI

Namespace Detail
	TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
End Namespace

Class Control
	Inherits WindowHandle
	Implements ActiveBasic.COM.InterfaceQuerable
Public
	/*!
	@brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
	@date	2008/07/16
	*/
	finalDestroy As ActiveBasic.Windows.UI.Handler

	Sub Control()
		comImpl = New COM.ComClassDelegationImpl(This)
	End Sub

	Virtual Sub ~Control()
	End Sub

	Function Handle() As HWND
		Handle = hwnd
	End Function

	/*!
	@brief HWNDからControlインスタンスを取得する。
	@param[in] hwnd 対象のウィンドウハンドル
	@return 対応するControlインスタンス。ただし、存在しなければNothing。
	*/
	Static Function FromHWnd(hwnd As HWND) As Control
		FromHWnd = Nothing
		If _System_IsWindow(hwnd) Then
			FromHWnd = FromHWndCore(hwnd)
		End If
	End Function

Private
	Static Function FromHWndCore(hwnd As HWND) As Control
		FromHWndCore = _System_PtrObj(GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As VoidPtr) As Control
	End Function

'--------------------------------
' ウィンドウ作成
'	Function Create(
'		parent As HWND,
'		rect As RECT,
'		name As String,
'		style As DWord,
'		exStyle = 0 As DWord,
'		menu = 0 As HMENU) As HWND

Public
	/*!
	@brief ウィンドウを作成する（詳細版）。
	@date 2008/08/02
	通常はCreateやCreateFormその他を使ってください。
	*/
	Sub CreateEx(parent As Control, style As DWord, exStyle As DWord, hmenu As HMENU)
		Dim cs As CREATESTRUCT
		With cs
			.dwExStyle = exStyle
			.lpszClass = (atom As ULONG_PTR) As LPCTSTR
			.lpszName = 0
			.style = style
			.x = 0
			.y = 0
			.cx = 0
			.cy = 0
			If IsNothing(parent) Then
				.hwndParent = 0
			Else
				.hwndParent = parent As HWND
			End If
			.hMenu = hmenu
			.hInstance = hInstance
		End With
		GetCreateStruct(cs)
		createImpl(cs, parent)
	End Sub

	/*!
	@brief ウィンドウを作成する（子ウィンドウ以外）。
	@date 2008/08/02
	*/
	Sub CreateForm(style As DWord, exStyle As DWord, owner = Nothing As Control, hmenu = 0 As HMENU)
		CreateEx(owner, style, exStyle, hmenu)
	End Sub

	Sub CreateForm()
		CreateEx(Nothing, 0, 0, 0)
	End Sub

	/*!
	@brief 子ウィンドウを作成する。
	@date 2008/08/02
	*/
	Sub Create(parent As Control, style = 0 As DWord, exStyle = 0 As DWord, id = 0 As Long)
		CreateEx(parent, style Or WS_CHILD Or WS_VISIBLE, exStyle, id As ULONG_PTR As HMENU)
	End Sub
Protected
	Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

	Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
		If hwnd <> 0 Then
			Throw New System.InvalidOperationException("Window already created.")
		End If

		StartWndProc()

		With cs
			'よそのウィンドウクラスの場合、WndProcFirst内のhwndの代入が行われないため、ここでも行っておく。
			hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
				.x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
			If hwnd = 0 Then
				ActiveBasic.Windows.ThrowByWindowsError(GetLastError())
			End If
			
			If IsNothing(FromHWndCore(hwnd)) <> False Then
				AssociateHWnd(hwnd)
				TlsSetValue(tlsIndex, 0)
			End If
		End With

		If IsNothing(parent) = False Then
			RegisterUnassociateHWnd(parent)
		End If
	End Sub

'--------------------------------
' ウィンドウプロシージャ
'Protected
Public
	Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		Dim h = Nothing As MessageHandler
		Dim b = messageMap.TryGetValue(Hex$(msg), h)
		If b Then
			If Not IsNothing(h) Then
				Dim a = New MessageArgs(hwnd, msg, wp, lp)
				h(This, a)
				WndProc = a.LResult
				Exit Function
			End If
		End If
		WndProc = DefWndProc(msg, wp, lp)
	End Function

	Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
	End Function

Private
	Static Function makeKeysFormMsg(e As MessageArgs) As Keys
		Dim t As DWord
		t = e.WParam And Keys.KeyCode
		t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
		t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
		t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
		makeKeysFormMsg = t As Keys
	End Function

	Static Function makeMouseEventFromMsg(e As MessageArgs) As MouseArgs
		Dim wp = e.WParam
		Dim lp = e.LParam
		makeMouseEventFromMsg = New MouseArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
	End Function

Protected
	/*!
	@brief	最初にウィンドウプロシージャを使うための前処理を行う関数
	@date	2008/07/11
	WndProcFirstを使うときは、この関数を呼んでおく必要がある。
	*/
	Sub StartWndProc()
		TlsSetValue(tlsIndex, ObjPtr(This))
		registerStandardEvent()
	End Sub
Private
	/*!
	@brief	主なメッセージハンドラの登録を行う関数
	@date	2008/08/02
	*/
	Sub registerStandardEvent()
		AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
		Dim md = New MessageHandler(AddressOf(OnMouseDownBase))
		AddMessageEvent(WM_LBUTTONDOWN, md)
		AddMessageEvent(WM_RBUTTONDOWN, md)
		AddMessageEvent(WM_MBUTTONDOWN, md)
		AddMessageEvent(WM_XBUTTONDOWN, md)
		Dim mu = New MessageHandler(AddressOf(OnMouseUpBase))
		AddMessageEvent(WM_LBUTTONUP, mu)
		AddMessageEvent(WM_RBUTTONUP, mu)
		AddMessageEvent(WM_MBUTTONUP, mu)
		AddMessageEvent(WM_XBUTTONUP, mu)
		Dim mb = New MessageHandler(AddressOf(OnMouseDblClkBase))
		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))
		AddMessageEvent(WM_CHAR, AddressOf(OnChar))	
		AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
		AddMessageEvent(WM_SIZE, AddressOf(OnSize))
	End Sub

	Sub OnEraseBackground(sender As Object, e As MessageArgs)
		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

	Sub OnMouseDownBase(sender As Object, e As MessageArgs)
		OnMouseDown(makeMouseEventFromMsg(e))
	End Sub

	Sub OnMouseUpBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		If doubleClickFired = False Then
			OnClick(Args.Empty)
			OnMouseClick(me)
		Else
			doubleClickFired = False
		End If
		OnMouseUp(me)
	End Sub

	Sub OnMouseDblClkBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		doubleClickFired = True
		OnMouseDown(me)
		OnDoubleClick(Args.Empty)
		OnMouseDoubleClick(me)
	End Sub

	Sub OnMouseMoveBase(sender As Object, e As MessageArgs)
		Dim me = makeMouseEventFromMsg(e)
		If mouseEntered = False Then
			mouseEntered = True
			OnMouseEnter(me)
			trackMouseEvent(TME_LEAVE Or TME_HOVER)
		End If
		OnMouseMove(me)
	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)
		OnMouseHover(me)
	End Sub

	Sub OnPaintBase(sender As Object, e As MessageArgs)
		Dim ps As PAINTSTRUCT
		BeginPaint(ps)
		Try
			OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
		Finally
			EndPaint(ps)
		End Try
	End Sub

	Sub OnKeyDownBase(sender As Object, e As MessageArgs)
		OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
	End Sub

	Sub OnKeyUpBase(sender As Object, e As MessageArgs)
		OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
	End Sub

	Sub OnChar(sender As Object, e As MessageArgs)
		OnKeyPress(New KeyPressArgs(e.WParam As Char))
	End Sub

	Sub OnCreateBase(sender As Object, e As MessageArgs)
		OnCreate(New CreateArgs(e.LParam As *CREATESTRUCT))
	End Sub

	Sub OnSize(sender As Object, e As MessageArgs)
		OnResize(New ResizeArgs(e.WParam, e.LParam))
	End Sub

	messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageHandler>

Public
	/*!
	@biref	メッセージイベントハンドラを登録する。
	@date	2007/12/04
	*/
	Sub AddMessageEvent(message As DWord, h As MessageHandler)
		If Not IsNothing(h) Then
			If IsNothing(messageMap) Then
				messageMap = New System.Collections.Generic.Dictionary<Object, MessageHandler>
			End If
			Dim msg = Hex$(message)
			Dim m = Nothing As MessageHandler
			If messageMap.TryGetValue(msg, m) Then
				messageMap.Item[msg] = m + h
			Else
				messageMap.Item[msg] = h
			End If
		End If
	End Sub

	/*!
	@biref	メッセージイベントハンドラ登録を解除する。
	@date	2007/12/04
	*/
	Sub RemoveMessageEvent(message As DWord, a As MessageHandler)
		If Not IsNothing(a) Then
			If Not IsNothing(messageMap) Then
				Dim msg = Hex$(message)
				Dim m = messageMap.Item[msg]
				If Not IsNothing(m) Then
					messageMap.Item[msg] = m - a
				End If
			End If
		End If
	End Sub

'--------------------------------
' ウィンドウメッセージ処理


'--------
'イベント

#include "ControlEvent.sbp"

'--------------------------------
' インスタンスメンバ変数
Private
	/*!
	@brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
	外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
	*/
	mouseEntered As Boolean
	/*!
	@brief ダブルクリックが起こったかどうかのフラグ
	Click/MouseClickイベントのために用意している。
	@date	2008/07/12
	*/
	doubleClickFired As Boolean

'--------------------------------
' 初期ウィンドウクラス
Protected
	Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		Imports System.Runtime.InteropServices

		Dim rThis = FromHWndCore(hwnd)
		If IsNothing(rThis) Then
			rThis = _System_PtrObj(TlsGetValue(tlsIndex)) As Control
			TlsSetValue(tlsIndex, 0)
			If IsNothing(rThis) Then
				Goto *InstanceIsNotFound
			End If
			' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
			rThis.AssociateHWnd(hwnd)
		End If
		If msg = WM_NCDESTROY Then
			rThis.UnassociateHWnd()
		End If
		If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
			Dim f = rThis.finalDestroy
			f(rThis, Args.Empty)
'			finalDestroy(This, Args.Empty)
		End If
		WndProcFirst = rThis.WndProc(msg, wp, lp)
		Exit Function

	*InstanceIsNotFound
		Dim err = "ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found. msg = &h" _
			+ Hex$(msg) + Ex"\r\n"
		OutputDebugString(ToTCStr(err))
		WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
	End Function

	/*!
	@brief	Controlインスタンスとウィンドウハンドルを結び付ける。
	@param[in] hwnd	結び付けるウィンドウハンドル
	@date	2008/07/16
	これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなると共に、
	FromHWndでウィンドウハンドルからControlインスタンスの取得が可能となる。
	*/
	Sub AssociateHWnd(hwnd As HWND)
		This.hwnd = hwnd
		This.Prop[PropertyInstance] = ObjPtr(This) As HANDLE
		comImpl.AddRef()
	End Sub

	/*!
	@brief	オーナーの破棄時にこのControlインスタンスとウィンドウハンドルの結び付けを解除するよう登録する。
	@param[in] owner 結び付けの解除を連動させるControl
	@date	2008/07/16
	ownerのFinalDestoryでこのControlとHWNDとの結び付けを解除する。
	*/
	Sub RegisterUnassociateHWnd(owner As Control)
		If IsNothing(owner) = False Then
			Dim e = New Handler(AddressOf(UnassociateHWndOnEvent))
			If IsNothing(finalDestroy) Then
				owner.finalDestroy = e
			Else
				owner.finalDestroy += e
			End If
		End If
	End Sub

	Sub UnassociateHWndOnEvent(sender As Object, e As Args)
		UnassociateHWnd()
	End Sub

	Sub UnassociateHWnd()
		comImpl.Release()
	End Sub

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

'--------------------------------
'	インタフェース実装

Public
	Virtual Function QueryInterfaceImpl(ByRef iid As IID, ByRef pv As VoidPtr) As HRESULT
		QueryInterfaceImpl = E_NOTIMPL
	End Function

Private
	comImpl As COM.ComClassDelegationImpl
'--------------------------------
'	その他の補助関数
Private
	Function trackMouseEvent(flags As DWord) As BOOL
		If pTrackMouseEvent <> 0 Then
			Dim tme As TRACKMOUSEEVENT
			With tme
				.cbSize = Len(tme)
				.dwFlags = flags
				.hwndTrack = hwnd
				.dwHoverTime = HOVER_DEFAULT
			End With
			trackMouseEvent = pTrackMouseEvent(tme)
		End If
	End Function

'--------------------------------
' 初期化終了関連（特にウィンドウクラス）
Private
	'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
	Static tlsIndex As DWord

	Static hInstance As HINSTANCE
	Static atom As ATOM
	Static hmodComctl As HMODULE
	Static pTrackMouseEvent As Detail.PTrackMouseEvent

	Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
	Static Const PropertyInstance = 0 As ATOM
Public
	Static Sub Initialize(hinst As HINSTANCE)
		tlsIndex = TlsAlloc()
		hInstance = hinst
		hmodComctl = LoadLibrary("comctl32.dll")
		pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent")) As Detail.PTrackMouseEvent

		Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
		PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))

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

	Static Sub Uninitialize()
		If atom <> 0 Then
			UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
		End If
		If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
			TlsFree(tlsIndex)
		End If
		If hmodComctl <> 0 Then
			FreeLibrary(hmodComctl)
		End If
		If PropertyInstance <> 0 Then
			GlobalDeleteAtom(PropertyInstance)
		End If
	End Sub

End Class

End Namespace 'UI
End Namespace 'Widnows
End Namespace 'ActiveBasic
