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

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

Namespace ActiveBasic
Namespace Windows
Namespace UI

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

Class Control
	Inherits WindowHandle
Public

	Sub Control()
	End Sub

	Virtual Sub ~Control()
	End Sub

	Function Handle() As HWND
		Handle = hwnd
	End Function

	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
		If _System_GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
			Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
			If gchValue <> 0 Then
				Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
				FromHWndCore = gch.Target As Control
				Exit Function
			End If
		End If
	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
	Sub Create()
		Dim cs As CREATESTRUCT
		cs.hInstance = hInstance
		cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
		GetCreateStruct(cs)
		createImpl(cs)
	End Sub

Protected
	Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

	Sub createImpl(ByRef cs As CREATESTRUCT)
		Imports System.Runtime.InteropServices

		Dim gch = GCHandle.Alloc(This)
		TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)

		StartWndProc()

		With cs
			Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
				.x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
			If hwnd = 0 Then
				ActiveBasic.Windows.ThrowByWindowsError(GetLastError())
			End If
		End With
	End Sub

'--------------------------------
' ウィンドウプロシージャ
'Protected
Public
	Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		Dim h = Nothing As MessageEventHandler
		Dim b = messageMap.TryGetValue(Hex$(msg), h)
		If b Then
			If Not IsNothing(h) Then
				Dim a = New MessageEventArgs(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 MessageEventArgs) 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 MessageEventArgs) As MouseEventArgs
		Dim wp = e.WParam
		Dim lp = e.LParam
		makeMouseEventFromMsg = New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
	End Function

	/*!
	@brief	最初にウィンドウプロシージャが呼ばれるときに実行される関数
	ここでは、主なメッセージハンドラの登録を行っている。
	@date	2008/07/11
	*/
	Sub StartWndProc()
		AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
		Dim md = New MessageEventHandler(AddressOf(OnMouseDownBase))
		AddMessageEvent(WM_LBUTTONDOWN, md)
		AddMessageEvent(WM_RBUTTONDOWN, md)
		AddMessageEvent(WM_MBUTTONDOWN, md)
		AddMessageEvent(WM_XBUTTONDOWN, md)
		Dim mu = New MessageEventHandler(AddressOf(OnMouseUpBase))
		AddMessageEvent(WM_LBUTTONUP, mu)
		AddMessageEvent(WM_RBUTTONUP, mu)
		AddMessageEvent(WM_MBUTTONUP, mu)
		AddMessageEvent(WM_XBUTTONUP, mu)
		Dim mb = New MessageEventHandler(AddressOf(OnMouseDblClkBase))
		AddMessageEvent(WM_LBUTTONDBLCLK, mu)
		AddMessageEvent(WM_RBUTTONDBLCLK, mu)
		AddMessageEvent(WM_MBUTTONDBLCLK, mu)
		AddMessageEvent(WM_XBUTTONDBLCLK, mu)

		AddMessageEvent(WM_MOUSEMOVE, AddressOf(OnMouseMoveBase))
		AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase))
		AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase))
		AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase))
'		AddMessageEvent(WM_CHAR, AddressOf(OnChar))	
		AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
	End Sub

	Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
		Dim rc = ClientRect
		FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
		e.LResult = TRUE
	End Sub

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

	Sub OnMouseUpBase(sender As Object, e As MessageEventArgs)
		Dim me = makeMouseEventFromMsg(e)
		If doubleClickFired = False Then
'			OnClick(System.EventArgs.Empty)
			OnMouseClick(me)
			doubleClickFired = False
		End If
		OnMouseUp(me)
	End Sub

	Sub OnMouseDblClkBase(sender As Object, e As MessageEventArgs)
		Dim me = makeMouseEventFromMsg(e)
		doubleClickFired = True
		OnMouseDown(me)
'		OnDoubleClick(System.EventArgs.Empty)
		OnMouseDoubleClick(me)
	End Sub

	Sub OnMouseMoveBase(sender As Object, e As MessageEventArgs)
		Dim me = makeMouseEventFromMsg(e)
		If mouseEntered Then
			OnMouseMove(me)
		Else
			mouseEntered = True
			OnMouseEnter(me)
		End If
	End Sub

	Sub OnMouseLeaveBase(sender As Object, e As MessageEventArgs)
		Dim me = makeMouseEventFromMsg(e)
		OnMouseLeave(me)
		mouseEntered = False
	End Sub

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

	Sub OnKeyDownBase(sender As Object, e As MessageEventArgs)
		OnKeyDown(New KeyEventArgs(makeKeysFormMsg(e)))
	End Sub

	Sub OnKeyUpBase(sender As Object, e As MessageEventArgs)
		OnKeyUp(New KeyEventArgs(makeKeysFormMsg(e)))
	End Sub

'	コメントアウト解除のときはStartWndProcのコメントアウト解除も忘れないこと
'	Sub OnChar(sender As Object, e As MessageEventArgs)
'		OnKeyPress(New KeyPressEventArgs(e.WParam As Char))
'	End Sub

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

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

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

'--------------------------------
' 初期ウィンドウクラス
Private
	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
			Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
			TlsSetValue(tlsIndex, 0)
			If gchValue = 0 Then
				Goto *InstanceIsNotFound
			End If
			Dim gch = GCHandle.FromIntPtr(gchValue)
			rThis = gch.Target As Control
			' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき

			If IsNothing(rThis) Then
				Goto *InstanceIsNotFound
			End If
			rThis.hwnd = hwnd
			rThis.Prop[PropertyInstance] = gchValue As HANDLE
		End If
		WndProcFirst = rThis.WndProc(msg, wp, lp)
		If msg = WM_NCDESTROY Then
			Dim gchValue = rThis.Prop(PropertyInstance) As ULONG_PTR
			If gchValue <> 0 Then
				GCHandle.FromIntPtr(gchValue).Free()
			End If
		End If

		Exit Function

	*InstanceIsNotFound
		OutputDebugString(Ex"ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.\r\n")
		WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
	End Function

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

'--------------------------------
'	その他の補助関数
Private
'	Sub tracMouseEvent()
/*		If pTrackMouseEvent <> 0 Then
			Dim tme As TRACKMOUSEEVENT
			With tme
				.cbSize = Len(tme)
				.dwFlags = TME_HOVER Or TME_LEAVE
				.hwndTrack = wnd
				.dwHoverTime = HOVER_DEFAULT
			End With
			pTrackMouseEvent(tme)
		End If
*/	'End Sub

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

	Static hInstance As HINSTANCE
	Static atom As ATOM
	Static hmodComctl As HMODULE
'	Static pTrackMouseEvent As 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"))

		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