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

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

Namespace ActiveBasic
Namespace Windows
Namespace UI
Namespace Forms

Class Control
Public

'1

	Sub Control()
	End Sub

	Virtual Sub ~Control()
	End Sub

	Function Handle() As WindowHandle
		Handle = wnd
	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)

		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_ERASEBKGND
				Dim rc = wnd.ClientRect
				Dim e = New PaintDCHandledEventArgs(wp As HDC, rc)
				OnPaintBackground(e)
				WndProc = e.Handled
			Case WM_PAINT
				Dim ps As PAINTSTRUCT
				wnd.BeginPaint(ps)
				Try
					Dim e = New PaintDCEventArgs(ps.hdc, ps.rcPaint)
					OnPaintDC(e)
				Finally
					wnd.EndPaint(ps)
				End Try
			Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN, WM_XBUTTONDOWN
				OnMouseDown(New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0))
			Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP, WM_XBUTTONUP
				OnMouseUp(New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0))
/*
			Case WM_KEYDOWN
				OnKeyDown(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
			Case WM_KEYUP
				OnKeyUp(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
			Case WM_CHAR
				OnKeyPress(New KeyPressEventArgs(wParam As Char))
			Case WM_ENABLE
				OnEnableChanged(EventArgs.Empty)
			Case WM_MOVE
				OnMove(EventArgs.Empty)
			Case WM_SIZE
				OnResize(EventArgs.Empty)
*/
			Case Else
			WndProc = DefWndProc(msg, wp, lp)
		End Select
	End Function

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

Private
	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


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

'--------
' 2

Protected
	/*!
	@biref	ウィンドウの背景を描画する。
	@date	2007/12/04
	*/
	Virtual Sub OnPaintBackground(e As PaintDCBackGroundEventArgs)
		Dim hbr = (COLOR_3DFACE + 1) As HBRUSH
		FillRect(e.Handle, e.ClipRect, hbr)
		e.Handled = True
	End Sub

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

#include "ControlEvent.sbp"

'--------------------------------
' 1 インスタンスメンバ変数
Private
	wnd As WindowHandle

'--------------------------------
' 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.wnd = New WindowHandle(hwnd)
			rThis.wnd.SetProp(PropertyInstance, 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

'--------------------------------
' 1 初期化終了関連（特にウィンドウクラス）

	'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
	Static tlsIndex As DWord

	Static hInstance As HINSTANCE
	Static atom As ATOM

	Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
	Static Const PropertyInstance = 0 As ATOM
Public
	Static Sub Initialize(hinst As HINSTANCE)
		tlsIndex = TlsAlloc()
		hInstance = hinst

		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()
		UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
		TlsFree(tlsIndex)
		GlobalDeleteAtom(PropertyInstance)
	End Sub
End Class

Namespace Detail
Class _System_ControlIinitializer
Public
	Sub _System_ControlIinitializer(hinst As HINSTANCE)
		Control.Initialize(hinst)
	End Sub

	Sub ~_System_ControlIinitializer()
		Control.Uninitialize()
	End Sub
End Class

#ifndef _SYSTEM_NO_INITIALIZE_CONTROL_
Dim _System_ControlInitializer As _System_ControlIinitializer(GetModuleHandle(0))
#endif '_SYSTEM_NO_INITIALIZE_CONTROL_

End Namespace 'Detail

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 WM_DESTROY
				PostQuitMessage(0)
			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

Class Bar
Public
Static Sub PaintDCEvent(sender As Object, et As PaintDCEventArgs) 
	Dim e = et As PaintDCEventArgs
	TextOut(e.Handle, 10, 10, "Hello, world", 12)
End Sub
End Class

Dim f = New Form
f.Create()
Dim v = New PaintDCEventHandler(AddressOf (Bar.PaintDCEvent))
f.AddPaintDC(v)
f.Handle.Show(SW_SHOW)

MessageBox(0, "hello", "", 0)