source: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Forms/Control.ab@ 544

Last change on this file since 544 was 544, checked in by イグトランス (egtra), 16 years ago

キー関連とCreateイベントの追加

File size: 12.9 KB
Line 
1'Classes/ActiveBasic/Windows/UI/Control.ab
2
3#require <Classes/ActiveBasic/Windows/UI/Forms/EventArgs.ab>
4
5Namespace ActiveBasic
6Namespace Windows
7Namespace UI
8Namespace Forms
9
10'Namespace Detail
11' TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
12'End Namespace
13
14Class Control
15Public
16 Sub Control()
17 End Sub
18
19 Virtual Sub ~Control()
20 End Sub
21
22 Function Handle() As HWND
23 Handle = hwnd
24 End Function
25
26 Static Function FromHWnd(hwnd As HWND) As Control
27 FromHWnd = Nothing
28 If IsWindow(hwnd) Then
29 FromHWnd = FromHWndCore(hwnd)
30 End If
31 End Function
32
33Private
34 Static Function FromHWndCore(hwnd As HWND) As Control
35 If GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
36 Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
37 If gchValue <> 0 Then
38 Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
39 FromHWndCore = gch.Target As Control
40 Exit Function
41 End If
42 End If
43 End Function
44
45'--------------------------------
46' ウィンドウ作成
47/*
48 Function Create(
49 parent As HWND,
50 rect As RECT,
51 name As String,
52 style As DWord,
53 exStyle = 0 As DWord,
54 menu = 0 As HMENU) As HWND
55*/
56
57Public
58 Function Create() As Boolean
59 Dim cs As CREATESTRUCT
60 cs.hInstance = hInstance
61 cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
62 GetCreateStruct(cs)
63 Create = createImpl(cs)
64 End Function
65
66Protected
67 Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
68
69 Function createImpl(ByRef cs As CREATESTRUCT) As Boolean
70 Imports System.Runtime.InteropServices
71
72 Dim gch = GCHandle.Alloc(This)
73 TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)
74
75 StartWndProc()
76
77 With cs
78 Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
79 .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
80 createImpl = hwnd <> 0
81 End With
82 End Function
83
84'--------------------------------
85' ウィンドウプロシージャ
86'Protected
87Public
88 Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
89 Dim h = Nothing As MessageEventHandler
90 Dim b = messageMap.TryGetValue(Hex$(msg), h)
91 If b Then
92 If Not IsNothing(h) Then
93 Dim a = New MessageEventArgs(hwnd, msg, wp, lp)
94 h(This, a)
95 WndProc = a.LResult
96 Exit Function
97 End If
98 End If
99 WndProc = DefWndProc(msg, wp, lp)
100 End Function
101
102 Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
103 DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
104 End Function
105
106Private
107 Static Function makeKeysFormMsg(e As MessageEventArgs) As Keys
108 Dim t As DWord
109 t = e.WParam And Keys.KeyCode
110 t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
111 t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
112 t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
113 makeKeysFormMsg = t As Keys
114 End Function
115
116 Static Function makeMouseEventFromMsg(e As MessageEventArgs) As MouseEventArgs
117 Dim wp = e.WParam
118 Dim lp = e.LParam
119 makeMouseEventFromMsg = New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
120 End Function
121
122 /*!
123 @brief 最初にウィンドウプロシージャが呼ばれるときに実行される関数
124 ここでは、主なメッセージハンドラの登録を行っている。
125 @date 2008/07/11
126 */
127 Sub StartWndProc()
128 Dim t = This '#177対策
129 AddMessageEvent(WM_ERASEBKGND, AddressOf(t.OnEraseBackground))
130 Dim md = New MessageEventHandler(AddressOf(t.OnMouseDownBase))
131 AddMessageEvent(WM_LBUTTONDOWN, md)
132 AddMessageEvent(WM_RBUTTONDOWN, md)
133 AddMessageEvent(WM_MBUTTONDOWN, md)
134 AddMessageEvent(WM_XBUTTONDOWN, md)
135 Dim mu = New MessageEventHandler(AddressOf(t.OnMouseUpBase))
136 AddMessageEvent(WM_LBUTTONUP, mu)
137 AddMessageEvent(WM_RBUTTONUP, mu)
138 AddMessageEvent(WM_MBUTTONUP, mu)
139 AddMessageEvent(WM_XBUTTONUP, mu)
140 Dim mb = New MessageEventHandler(AddressOf(t.OnMouseDblClkBase))
141 AddMessageEvent(WM_LBUTTONDBLCLK, mu)
142 AddMessageEvent(WM_RBUTTONDBLCLK, mu)
143 AddMessageEvent(WM_MBUTTONDBLCLK, mu)
144 AddMessageEvent(WM_XBUTTONDBLCLK, mu)
145
146 AddMessageEvent(WM_MOUSELEAVE, AddressOf(t.OnMouseLeaveBase))
147 AddMessageEvent(WM_PAINT, AddressOf(t.OnPaintBase))
148 AddMessageEvent(WM_KEYDOWN, AddressOf(t.OnKeyDownBase))
149' AddMessageEvent(WM_CHAR, AddressOf(t.OnChar))
150 AddMessageEvent(WM_CREATE, AddressOf(t.OnCreateBase))
151 End Sub
152
153 Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
154 Dim rc As RECT
155 Dim r = GetClientRect(hwnd, rc)
156 FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
157 e.LResult = TRUE
158 End Sub
159
160 Sub OnMouseDownBase(sender As Object, e As MessageEventArgs)
161 OnMouseDown(makeMouseEventFromMsg(e))
162 End Sub
163
164 Sub OnMouseUpBase(sender As Object, e As MessageEventArgs)
165 Dim me = makeMouseEventFromMsg(e)
166 If doubleClickFired = False Then
167' OnClick(System.EventArgs.Empty)
168 OnMouseClick(me)
169 doubleClickFired = False
170 End If
171 OnMouseUp(me)
172 End Sub
173
174 Sub OnMouseDblClkBase(sender As Object, e As MessageEventArgs)
175 Dim me = makeMouseEventFromMsg(e)
176 doubleClickFired = True
177 OnMouseDown(me)
178' OnDoubleClick(System.EventArgs.Empty)
179 OnMouseDoubleClick(me)
180 End Sub
181
182 Sub OnMouseMoveBase(sender As Object, e As MessageEventArgs)
183 Dim me = makeMouseEventFromMsg(e)
184 If mouseEntered Then
185 OnMouseMove(me)
186 Else
187 mouseEntered = True
188 OnMouseEnter(me)
189 End If
190 End Sub
191
192 Sub OnMouseLeaveBase(sender As Object, e As MessageEventArgs)
193 Dim me = makeMouseEventFromMsg(e)
194 OnMouseLeave(me)
195 mouseEntered = False
196 End Sub
197
198 Sub OnPaintBase(sender As Object, e As MessageEventArgs)
199 Dim ps As PAINTSTRUCT
200 BeginPaint(hwnd, ps)
201 Try
202 OnPaintDC(New PaintDCEventArgs(ps.hdc, ps.rcPaint))
203 Finally
204 EndPaint(hwnd, ps)
205 End Try
206 End Sub
207
208 Sub OnKeyDownBase(sender As Object, e As MessageEventArgs)
209 OnKeyDown(New KeyEventArgs(makeKeysFormMsg(e)))
210 End Sub
211
212 Sub OnKeyUpBase(sender As Object, e As MessageEventArgs)
213 OnKeyUp(New KeyEventArgs(makeKeysFormMsg(e)))
214 End Sub
215
216' コメントアウト解除のときはStartWndProcのコメントアウト解除も忘れないこと
217' Sub OnChar(sender As Object, e As MessageEventArgs)
218' OnKeyPress(New KeyPressEventArgs(e.WParam As Char))
219' End Sub
220
221 Sub OnCreateBase(sender As Object, e As MessageEventArgs)
222 OnCreate(New CreateEventArgs(e.LParam As *CREATESTRUCT))
223 End Sub
224
225 messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageEventHandler>
226
227Public
228 /*!
229 @biref メッセージイベントハンドラを登録する。
230 @date 2007/12/04
231 */
232 Sub AddMessageEvent(message As DWord, h As MessageEventHandler)
233 If Not IsNothing(h) Then
234 If IsNothing(messageMap) Then
235 messageMap = New System.Collections.Generic.Dictionary<Object, MessageEventHandler>
236 End If
237 Dim msg = Hex$(message)
238 Dim m = Nothing As MessageEventHandler
239 If messageMap.TryGetValue(msg, m) Then
240 messageMap.Item[msg] = m + h
241 Else
242 messageMap.Item[msg] = h
243 End If
244 End If
245 End Sub
246
247 /*!
248 @biref メッセージイベントハンドラ登録を解除する。
249 @date 2007/12/04
250 */
251 Sub RemoveMessageEvent(message As DWord, a As MessageEventHandler)
252 If Not IsNothing(a) Then
253 If Not IsNothing(messageMap) Then
254 Dim msg = Nothing As Object : msg = New System.UInt32(message)
255 Dim m = messageMap.Item[msg]
256 If Not IsNothing(m) Then
257 messageMap.Item[msg] = m - a
258 End If
259 End If
260 End If
261 End Sub
262
263'--------------------------------
264' ウィンドウメッセージ処理
265
266
267'--------
268'イベント
269
270#include "ControlEvent.sbp"
271
272'--------------------------------
273' インスタンスメンバ変数
274Private
275 hwnd As HWND
276 /*!
277 @brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
278 外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
279 */
280 mouseEntered As Boolean
281 /*!
282 @brief ダブルクリックが起こったかどうかのフラグ
283 Click/MouseClickイベントのために用意している。
284 @date 2008/07/12
285 */
286 doubleClickFired As Boolean
287
288'--------------------------------
289' 初期ウィンドウクラス
290Private
291 Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
292 Imports System.Runtime.InteropServices
293
294 Dim rThis = Control.FromHWndCore(hwnd)
295 If IsNothing(rThis) Then
296 Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
297 TlsSetValue(tlsIndex, 0)
298 If gchValue = 0 Then
299 Goto *InstanceIsNotFound
300 End If
301 Dim gch = GCHandle.FromIntPtr(gchValue)
302 rThis = gch.Target As Control
303 ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
304
305 If IsNothing(rThis) Then
306 Goto *InstanceIsNotFound
307 End If
308 rThis.hwnd = hwnd
309 SetProp(hwnd, PropertyInstance As ULONG_PTR As PCSTR, gchValue As HANDLE)
310 End If
311 WndProcFirst = rThis.WndProc(msg, wp, lp)
312 If msg = WM_NCDESTROY Then
313 Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
314 If gchValue <> 0 Then
315 Dim gch = GCHandle.FromIntPtr(gchValue)
316 gch.Free()
317 End If
318 End If
319
320 Exit Function
321
322 *InstanceIsNotFound
323 OutputDebugString("ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.")
324 WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
325 End Function
326
327' Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
328' Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord
329
330'--------------------------------
331' その他の補助関数
332Private
333' Sub tracMouseEvent()
334/* If pTrackMouseEvent <> 0 Then
335 Dim tme As TRACKMOUSEEVENT
336 With tme
337 .cbSize = Len(tme)
338 .dwFlags = TME_HOVER Or TME_LEAVE
339 .hwndTrack = wnd
340 .dwHoverTime = HOVER_DEFAULT
341 End With
342 pTrackMouseEvent(tme)
343 End If
344*/ 'End Sub
345
346'--------------------------------
347' 初期化終了関連(特にウィンドウクラス)
348Private
349 'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
350 Static tlsIndex As DWord
351
352 Static hInstance As HINSTANCE
353 Static atom As ATOM
354 Static hmodComctl As HMODULE
355' Static pTrackMouseEvent As PTrackMouseEvent
356
357 Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
358 Static Const PropertyInstance = 0 As ATOM
359Public
360 Static Sub Initialize(hinst As HINSTANCE)
361 tlsIndex = TlsAlloc()
362 hInstance = hinst
363' hmodComctl = LoadLibrary("comctl32.dll")
364' pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent"))
365
366 Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
367 PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))
368
369 Dim wcx As WNDCLASSEX
370 With wcx
371 .cbSize = Len (wcx)
372 .style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
373 .lpfnWndProc = AddressOf (WndProcFirst)
374 .cbClsExtra = 0
375 .cbWndExtra = 0
376 .hInstance = hinst
377 .hIcon = 0
378 .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
379 .hbrBackground = 0
380 .lpszMenuName = 0
381 .lpszClassName = ToTCStr(WindowClassName)
382 .hIconSm = 0
383 End With
384 atom = RegisterClassEx(wcx)
385 If atom = 0 Then
386 Dim buf[1023] As TCHAR
387 wsprintf(buf, Ex"ActiveBasic.Windows.UI.Control.Control: RegisterClasseEx failed. Error code: &h%08X\r\n", GetLastError())
388 OutputDebugString(buf)
389 Debug
390 ExitThread(0)
391 End If
392 End Sub
393
394 Static Sub Uninitialize()
395 If atom <> 0 Then
396 UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
397 End If
398 If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
399 TlsFree(tlsIndex)
400 End If
401' If hmodComctl <> 0 Then
402' FreeLibrary(hmodComctl)
403' End If
404 If PropertyInstance <> 0 Then
405 GlobalDeleteAtom(PropertyInstance)
406 End If
407 End Sub
408
409End Class
410
411Class Form '仮
412 Inherits Control
413Protected
414 Override Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
415 With cs
416 .lpCreateParams = 0
417 '.hInstance
418 .hMenu = 0
419 .hwndParent = 0
420 .cy = CW_USEDEFAULT
421 .cx = CW_USEDEFAULT
422 .y = CW_USEDEFAULT
423 .x = CW_USEDEFAULT
424 .style = WS_OVERLAPPEDWINDOW
425 .lpszName = ""
426 '.lpszClass
427 .dwExStyle = 0
428 End With
429 End Sub
430Public
431
432 Override Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
433 WndProc = 0
434 Select Case msg
435 Case Else
436 WndProc = Super.WndProc(msg, wp, lp)
437 End Select
438 End Function
439End Class
440
441End Namespace 'Forms
442End Namespace 'UI
443End Namespace 'Widnows
444End Namespace 'ActiveBasic
445
446
447'----------
448'テスト実行用
449
450Imports ActiveBasic.Windows.UI.Forms
451
452'OleInitialize()
453Control.Initialize(GetModuleHandle(0))
454
455Class MyForm
456 Inherits Form
457Public
458 Sub t()
459 Dim f = This
460 f.AddMessageEvent(WM_DESTROY, AddressOf (f.Destory))
461 f.AddPaintDC(AddressOf (f.Paint))
462 End Sub
463
464 Sub Destory(sender As Object, e As EventArgs)
465 OutputDebugString(Ex"Destory\r\n")
466 PostQuitMessage(0)
467 End Sub
468
469 Sub Paint(sender As Object, e As PaintDCEventArgs)
470 TextOut(e.Handle, 10, 10, "Hello world!", 12)
471 End Sub
472End Class
473
474Dim f = New MyForm
475f.t()
476f.Create()
477ShowWindow(f.Handle, SW_SHOW)
478
479Dim m As MSG
480Do
481 Dim ret = GetMessage(m, 0, 0, 0)
482 If ret = 0 Then
483 Exit Do
484 ElseIf ret = -1 Then
485 ExitProcess(-1)
486 End If
487
488 TranslateMessage(m)
489 DispatchMessage(m)
490Loop
491
492f = Nothing
493System.GC.Collect()
494
495Control.Uninitialize()
496'OleUninitialize()
497
498End
Note: See TracBrowser for help on using the repository browser.