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

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

Namespace ActiveBasic
Namespace Windows
Namespace UI
Namespace Forms

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

Class Control
Public

'1

	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 IsWindow(hwnd) Then
			FromHWnd = FromHWndCore(hwnd)
		End If
	End Function

Private
	Static Function FromHWndCore(hwnd As HWND) As Control
		If 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

'--------------------------------
' 1 ウィンドウ作成
/*
	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
	Function Create() As Boolean
		Dim cs As CREATESTRUCT
		cs.hInstance = hInstance
		cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
		GetCreateStruct(cs)
		Create = createImpl(cs)
	End Function

Protected
	Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)

	Function createImpl(ByRef cs As CREATESTRUCT) As Boolean
		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)
			createImpl = hwnd <> 0
		End With
	End Function

'--------------------------------
' ウィンドウプロシージャ
'Protected
Public
	Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
/*
		Select Case msg
			Case WM_MOUSELEAVE
				OnMouseLeave(makeMouseEventFromWPLP(wp, lp))
				mouseEntered = False
			Case WM_KEYDOWN
				OnKeyDown(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
			Case WM_KEYUP
				OnKeyUp(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
			Case WM_CHAR
				OnKeyPress(New KeyPressEventArgs(wp As Char))
'			Case WM_CREATE
			Case WM_DESTROY
				OnDestroy(EventArgs.Empty)
			Case Else
				WndProc = DefWndProc(msg, wp, lp)
		End Select
*/
		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 makeKeysFormWPLP(wp As WPARAM, lp As LPARAM) As Keys
		Dim t As DWord
		t = wp 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
		makeKeysFormWPLP = t As Keys
	End Function

	Static Function makeMouseEventFromWPLP(wp As WPARAM, lp As LPARAM) As MouseEventArgs
		makeMouseEventFromWPLP = 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()
		Dim t = This '#177対策
		messageMap = New System.Collections.Generic.Dictionary<Object, MessageEventHandler>
		AddMessageEvent(WM_ERASEBKGND, AddressOf(t.OnEraseBackground))
		Dim md = New MessageEventHandler(AddressOf(t.OnMouseDownBase))
		AddMessageEvent(WM_LBUTTONDOWN, md)
		AddMessageEvent(WM_RBUTTONDOWN, md)
		AddMessageEvent(WM_MBUTTONDOWN, md)
		AddMessageEvent(WM_XBUTTONDOWN, md)
		Dim mu = New MessageEventHandler(AddressOf(t.OnMouseUpBase))
		AddMessageEvent(WM_LBUTTONUP, mu)
		AddMessageEvent(WM_RBUTTONUP, mu)
		AddMessageEvent(WM_MBUTTONUP, mu)
		AddMessageEvent(WM_XBUTTONUP, mu)
		Dim mb = New MessageEventHandler(AddressOf(t.OnMouseDblClkBase))
		AddMessageEvent(WM_LBUTTONDBLCLK, mu)
		AddMessageEvent(WM_RBUTTONDBLCLK, mu)
		AddMessageEvent(WM_MBUTTONDBLCLK, mu)
		AddMessageEvent(WM_XBUTTONDBLCLK, mu)
		AddMessageEvent(WM_PAINT, AddressOf(t.OnPaintBase))
	End Sub

	Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
		Dim rc As RECT
		Dim r = GetClientRect(hwnd, rc)
		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(makeMouseEventFromWPLP(e.WParam, e.LParam))
	End Sub

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

	Sub OnMouseDblClkBase(sender As Object, e As MessageEventArgs)
		Dim me = makeMouseEventFromWPLP(e.WParam, e.LParam)
		doubleClickFired = True
		OnMouseDown(me)
		OnDoubleClick(EventArgs.Empty)
		OnMouseDoubleClick(me)
	End Sub

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

	Sub OnPaintBase(sender As Object, e As MessageEventArgs)
		Dim ps As PAINTSTRUCT
		BeginPaint(hwnd, ps)
'		Try
'			OnPaintDC(New PaintDCEventArgs(ps.hdc, ps.rcPaint))
'		Finally
			EndPaint(hwnd, ps)
'		End Try
	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 = Nothing As Object : msg = New System.UInt32(message)
				Dim m = messageMap.Item[msg]
				If Not IsNothing(m) Then
					messageMap.Item[msg] = m - a
				End If
			End If
		End If
	End Sub

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


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

#include "ControlEvent.sbp"

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

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

		Dim rThis = Control.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
			SetProp(hwnd, PropertyInstance As ULONG_PTR As PCSTR, gchValue As HANDLE)
		End If
		WndProcFirst = rThis.WndProc(msg, wp, lp)
		If msg = WM_NCDESTROY Then
			Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
			If gchValue <> 0 Then
				Dim gch = GCHandle.FromIntPtr(gchValue)
				gch.Free()
			End If
		End If

		Exit Function

	*InstanceIsNotFound
		OutputDebugString("ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.")
		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

'--------------------------------
' 1 初期化終了関連（特にウィンドウクラス）
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

Class Form '仮
	Inherits Control
Protected
	Override Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
		With cs
			.lpCreateParams = 0
			'.hInstance
			.hMenu = 0
			.hwndParent = 0
			.cy = CW_USEDEFAULT
			.cx = CW_USEDEFAULT
			.y = CW_USEDEFAULT
			.x = CW_USEDEFAULT
			.style = WS_OVERLAPPEDWINDOW
			.lpszName = ""
			'.lpszClass
			.dwExStyle = 0
		End With
	End Sub
Public 

	Override Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
		WndProc = 0
		Select Case msg
			Case Else
				WndProc = Super.WndProc(msg, wp, lp)
		End Select
	End Function
End Class

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


'----------
'テスト実行用

Imports ActiveBasic.Windows.UI.Forms

'OleInitialize()
Control.Initialize(GetModuleHandle(0))

Class MyForm
	Inherits Form
Public
	Sub NcDestory(sender As Object, et As EventArgs)
		PostQuitMessage(0)
	End Sub
End Class

Dim f = New MyForm
f.Create()
Dim h = New MessageEventHandler(AddressOf (f.NcDestory))
f.AddMessageEvent(WM_NCDESTROY, h)
ShowWindow(f.Handle, SW_SHOW)

Dim m As MSG
Do
	Dim ret = GetMessage(m, 0, 0, 0)
	If ret = 0 Then
		Exit Do
	ElseIf ret = -1 Then
		ExitProcess(-1)
	End If

	TranslateMessage(m)
	DispatchMessage(m)
Loop

f = Nothing
System.GC.Collect()

Control.Uninitialize()
'OleUninitialize()

End