1 | 'Classes/ActiveBasic/Windows/UI/Control.ab
|
---|
2 |
|
---|
3 | #require <Classes/ActiveBasic/Windows/UI/EventArgs.ab>
|
---|
4 | #require <Classes/ActiveBasic/COM/ComClassBase.ab>
|
---|
5 |
|
---|
6 | Namespace ActiveBasic
|
---|
7 | Namespace Windows
|
---|
8 | Namespace UI
|
---|
9 |
|
---|
10 | Namespace Detail
|
---|
11 | TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
|
---|
12 | End Namespace
|
---|
13 |
|
---|
14 | /*
|
---|
15 | @brief Windowsのウィンドウを管理する基底クラス
|
---|
16 | @auther Egtra
|
---|
17 | */
|
---|
18 | Class Control
|
---|
19 | Inherits WindowHandle
|
---|
20 | Implements ActiveBasic.COM.InterfaceQuerable
|
---|
21 | Public
|
---|
22 | /*!
|
---|
23 | @brief Destroyイベントよりも後に呼ばれるDestroyイベントデリゲート
|
---|
24 | @date 2008/07/16
|
---|
25 | */
|
---|
26 | finalDestroy As ActiveBasic.Windows.UI.Handler
|
---|
27 |
|
---|
28 | Sub Control()
|
---|
29 | comImpl = New COM.ComClassDelegationImpl(This)
|
---|
30 | End Sub
|
---|
31 |
|
---|
32 | Function Handle() As HWND
|
---|
33 | Handle = hwnd
|
---|
34 | End Function
|
---|
35 |
|
---|
36 | /*!
|
---|
37 | @brief HWNDからControlインスタンスを取得する。
|
---|
38 | @param[in] hwnd 対象のウィンドウハンドル
|
---|
39 | @return 対応するControlインスタンス。存在しなければ作成される。ただし、hwndがNULLならNothing。
|
---|
40 | */
|
---|
41 | Static Function FromHWnd(hwnd As HWND) As Control
|
---|
42 | FromHWnd = Nothing
|
---|
43 | If IsWindow(hwnd) Then
|
---|
44 | FromHWnd = FromHWndCore(hwnd)
|
---|
45 | If ActiveBasic.IsNothing(FromHWnd) Then
|
---|
46 | Dim lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)
|
---|
47 | Try
|
---|
48 | FromHWnd = New Control
|
---|
49 | FromHWnd.registerStandardEvent()
|
---|
50 | FromHWnd.AssociateHWnd(hwnd)
|
---|
51 | Finally
|
---|
52 | lock.Dispose()
|
---|
53 | End Try
|
---|
54 | End If
|
---|
55 | End If
|
---|
56 | End Function
|
---|
57 |
|
---|
58 | Private
|
---|
59 | Static Function FromHWndCore(hwnd As HWND) As Control
|
---|
60 | FromHWndCore = _System_PtrObj(GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As VoidPtr) As Control
|
---|
61 | End Function
|
---|
62 |
|
---|
63 | '--------------------------------
|
---|
64 | ' ウィンドウ作成
|
---|
65 |
|
---|
66 | Public
|
---|
67 | /*!
|
---|
68 | @brief ウィンドウを作成する(詳細版)。
|
---|
69 | @date 2008/08/02
|
---|
70 | 通常はCreateやCreateFormその他を使ってください。
|
---|
71 | */
|
---|
72 | Sub CreateEx(parent As Control, style As DWord, exStyle As DWord, hmenu As HMENU)
|
---|
73 | Dim cs As CREATESTRUCT
|
---|
74 | With cs
|
---|
75 | .dwExStyle = exStyle
|
---|
76 | .lpszClass = (atom As ULONG_PTR) As LPCTSTR
|
---|
77 | .lpszName = 0
|
---|
78 | .style = style
|
---|
79 | .x = 0
|
---|
80 | .y = 0
|
---|
81 | .cx = 0
|
---|
82 | .cy = 0
|
---|
83 | If IsNothing(parent) Then
|
---|
84 | .hwndParent = 0
|
---|
85 | Else
|
---|
86 | .hwndParent = parent As HWND
|
---|
87 | End If
|
---|
88 | .hMenu = hmenu
|
---|
89 | .hInstance = hInstance
|
---|
90 | End With
|
---|
91 | GetCreateStruct(cs)
|
---|
92 | createImpl(cs, parent)
|
---|
93 | End Sub
|
---|
94 |
|
---|
95 | /*!
|
---|
96 | @brief ウィンドウを作成する(子ウィンドウ以外)。
|
---|
97 | @date 2008/08/02
|
---|
98 | */
|
---|
99 | Sub CreateForm(style As DWord, exStyle As DWord, owner = Nothing As Control, hmenu = 0 As HMENU)
|
---|
100 | CreateEx(owner, style, exStyle, hmenu)
|
---|
101 | End Sub
|
---|
102 |
|
---|
103 | Sub CreateForm()
|
---|
104 | CreateEx(Nothing, 0, 0, 0)
|
---|
105 | End Sub
|
---|
106 |
|
---|
107 | /*!
|
---|
108 | @brief 子ウィンドウを作成する。
|
---|
109 | @date 2008/08/02
|
---|
110 | */
|
---|
111 | Sub Create(parent As Control, style = 0 As DWord, exStyle = 0 As DWord, id = 0 As Long)
|
---|
112 | CreateEx(parent, style Or WS_CHILD Or WS_VISIBLE, exStyle, id As ULONG_PTR As HMENU)
|
---|
113 | End Sub
|
---|
114 |
|
---|
115 | Protected
|
---|
116 | Virtual Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
|
---|
117 | End Sub
|
---|
118 |
|
---|
119 | Sub createImpl(ByRef cs As CREATESTRUCT, parent As Control)
|
---|
120 | throwIfAlreadyCreated()
|
---|
121 |
|
---|
122 | StartWndProc()
|
---|
123 |
|
---|
124 | With cs
|
---|
125 | 'よそのウィンドウクラスの場合、WndProcFirst内のhwndの代入が行われないため、ここでも行っておく。
|
---|
126 | hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
|
---|
127 | .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
|
---|
128 | If hwnd = 0 Then
|
---|
129 | ThrowWithLastErrorNT("Control.CreateEx")
|
---|
130 | End If
|
---|
131 |
|
---|
132 | If IsNothing(FromHWndCore(hwnd)) <> False Then
|
---|
133 | AssociateHWnd(hwnd)
|
---|
134 | TlsSetValue(tlsIndex, 0)
|
---|
135 | End If
|
---|
136 | End With
|
---|
137 |
|
---|
138 | If IsNothing(parent) = False Then
|
---|
139 | RegisterUnassociateHWnd(parent)
|
---|
140 | End If
|
---|
141 | End Sub
|
---|
142 |
|
---|
143 | Public
|
---|
144 | /*
|
---|
145 | Sub Attach(hwndNew As HWND)
|
---|
146 | throwIfAlreadyCreated()
|
---|
147 | If hwndNew = 0 Then
|
---|
148 | Throw New System.ArgumentNullException("Control.Attach")
|
---|
149 | End If
|
---|
150 | registerStandardEvent()
|
---|
151 | AssociateHWnd(hwndNew)
|
---|
152 | End Sub
|
---|
153 | */
|
---|
154 | Sub BeginSubclass()
|
---|
155 | throwIfNotCreated()
|
---|
156 | prevWndProc = SetWindowLongPtr(hwnd, GWLP_WNDPROC, AddressOf(WndProcFirst) As LONG_PTR) As WNDPROC
|
---|
157 | End Sub
|
---|
158 |
|
---|
159 | Private
|
---|
160 | Sub throwIfAlreadyCreated()
|
---|
161 | If hwnd <> 0 Then
|
---|
162 | Throw New System.InvalidOperationException("Window is already created.")
|
---|
163 | End If
|
---|
164 | End Sub
|
---|
165 |
|
---|
166 | Sub throwIfNotCreated()
|
---|
167 | If hwnd = 0 Then
|
---|
168 | Throw New System.InvalidOperationException("Window is not already created.")
|
---|
169 | End If
|
---|
170 | End Sub
|
---|
171 |
|
---|
172 | '--------------------------------
|
---|
173 | ' ウィンドウプロシージャ
|
---|
174 |
|
---|
175 | Protected
|
---|
176 | Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
177 | If Not ProcessMessage(msg, wp, lp, WndProc) Then
|
---|
178 | WndProc = DefWndProc(msg, wp, lp)
|
---|
179 | End If
|
---|
180 | End Function
|
---|
181 |
|
---|
182 | Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
183 | If prevWndProc Then
|
---|
184 | DefWndProc = CallWindowProc(prevWndProc, hwnd, msg, wp, lp)
|
---|
185 | Else
|
---|
186 | DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
|
---|
187 | End If
|
---|
188 | End Function
|
---|
189 | Protected
|
---|
190 | Function ProcessMessage(msg As DWord, wp As WPARAM, lp As LPARAM, ByRef lr As LRESULT) As Boolean
|
---|
191 | Dim h = Nothing As MessageHandler
|
---|
192 | Dim b = messageMap.TryGetValue(Hex$(msg), h)
|
---|
193 | If b Then
|
---|
194 | If Not IsNothing(h) Then
|
---|
195 | Dim a = New MessageArgs(hwnd, msg, wp, lp)
|
---|
196 | h(This, a)
|
---|
197 | If a.Handled Then
|
---|
198 | lr = a.LResult
|
---|
199 | ProcessMessage = True
|
---|
200 | Exit Function
|
---|
201 | End If
|
---|
202 | End If
|
---|
203 | End If
|
---|
204 | ProcessMessage = False
|
---|
205 | End Function
|
---|
206 | Private
|
---|
207 | Static Function makeKeysFormMsg(e As MessageArgs) As Keys
|
---|
208 | Dim t As DWord
|
---|
209 | t = e.WParam And Keys.KeyCode
|
---|
210 | t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
|
---|
211 | t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
|
---|
212 | t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
|
---|
213 | makeKeysFormMsg = t As Keys
|
---|
214 | End Function
|
---|
215 |
|
---|
216 | Static Function makeMouseEventFromMsg(e As MessageArgs) As MouseArgs
|
---|
217 | Dim wp = e.WParam
|
---|
218 | Dim lp = e.LParam
|
---|
219 | makeMouseEventFromMsg = New MouseArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
|
---|
220 | End Function
|
---|
221 |
|
---|
222 | Protected
|
---|
223 | /*!
|
---|
224 | @brief 最初にウィンドウプロシージャを使うための前処理を行う関数
|
---|
225 | @date 2008/07/11
|
---|
226 | WndProcFirstを使うときは、この関数を呼んでおく必要がある。
|
---|
227 | */
|
---|
228 | Sub StartWndProc()
|
---|
229 | TlsSetValue(tlsIndex, ObjPtr(This))
|
---|
230 | registerStandardEvent()
|
---|
231 | End Sub
|
---|
232 | Private
|
---|
233 | /*!
|
---|
234 | @brief 主なメッセージハンドラの登録を行う関数
|
---|
235 | @date 2008/08/02
|
---|
236 | */
|
---|
237 | Sub registerStandardEvent()
|
---|
238 | AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
|
---|
239 | Dim md = New MessageHandler(AddressOf(OnMouseDownBase))
|
---|
240 | AddMessageEvent(WM_LBUTTONDOWN, md)
|
---|
241 | AddMessageEvent(WM_RBUTTONDOWN, md)
|
---|
242 | AddMessageEvent(WM_MBUTTONDOWN, md)
|
---|
243 | AddMessageEvent(WM_XBUTTONDOWN, md)
|
---|
244 | Dim mu = New MessageHandler(AddressOf(OnMouseUpBase))
|
---|
245 | AddMessageEvent(WM_LBUTTONUP, mu)
|
---|
246 | AddMessageEvent(WM_RBUTTONUP, mu)
|
---|
247 | AddMessageEvent(WM_MBUTTONUP, mu)
|
---|
248 | AddMessageEvent(WM_XBUTTONUP, mu)
|
---|
249 | Dim mb = New MessageHandler(AddressOf(OnMouseDblClkBase))
|
---|
250 | AddMessageEvent(WM_LBUTTONDBLCLK, mb)
|
---|
251 | AddMessageEvent(WM_RBUTTONDBLCLK, mb)
|
---|
252 | AddMessageEvent(WM_MBUTTONDBLCLK, mb)
|
---|
253 | AddMessageEvent(WM_XBUTTONDBLCLK, mb)
|
---|
254 |
|
---|
255 | AddMessageEvent(WM_MOUSEMOVE, AddressOf(OnMouseMoveBase))
|
---|
256 | AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase))
|
---|
257 | AddMessageEvent(WM_MOUSEHOVER, AddressOf(OnMouseHoverBase))
|
---|
258 | AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase))
|
---|
259 | AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase))
|
---|
260 | AddMessageEvent(WM_CHAR, AddressOf(OnChar))
|
---|
261 | AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
|
---|
262 | AddMessageEvent(WM_SIZE, AddressOf(OnSize))
|
---|
263 | End Sub
|
---|
264 |
|
---|
265 | Sub OnEraseBackground(sender As Object, e As MessageArgs)
|
---|
266 | Dim a = New PaintBackgroundArgs(e.WParam, e.LParam)
|
---|
267 | e.Handled = e.Handled And OnPaintBackground(a)
|
---|
268 | e.LResult = a.Painted
|
---|
269 | End Sub
|
---|
270 |
|
---|
271 | Sub OnMouseDownBase(sender As Object, e As MessageArgs)
|
---|
272 | e.Handled = e.Handled And OnMouseDown(makeMouseEventFromMsg(e))
|
---|
273 | End Sub
|
---|
274 |
|
---|
275 | Sub OnMouseUpBase(sender As Object, e As MessageArgs)
|
---|
276 | Dim me = makeMouseEventFromMsg(e)
|
---|
277 | If doubleClickFired = False Then
|
---|
278 | OnClick(Args.Empty)
|
---|
279 | OnMouseClick(me)
|
---|
280 | Else
|
---|
281 | doubleClickFired = False
|
---|
282 | End If
|
---|
283 | e.Handled = e.Handled And OnMouseUp(me)
|
---|
284 | End Sub
|
---|
285 |
|
---|
286 | Sub OnMouseDblClkBase(sender As Object, e As MessageArgs)
|
---|
287 | Dim me = makeMouseEventFromMsg(e)
|
---|
288 | doubleClickFired = True
|
---|
289 | OnMouseDown(me)
|
---|
290 | OnDoubleClick(Args.Empty)
|
---|
291 | e.Handled = e.Handled And OnMouseDoubleClick(me)
|
---|
292 | End Sub
|
---|
293 |
|
---|
294 | Sub OnMouseMoveBase(sender As Object, e As MessageArgs)
|
---|
295 | Dim me = makeMouseEventFromMsg(e)
|
---|
296 | If mouseEntered = False Then
|
---|
297 | mouseEntered = True
|
---|
298 | OnMouseEnter(me)
|
---|
299 | trackMouseEvent(TME_LEAVE Or TME_HOVER)
|
---|
300 | End If
|
---|
301 | e.Handled = e.Handled And OnMouseMove(me)
|
---|
302 | End Sub
|
---|
303 |
|
---|
304 | Sub OnMouseLeaveBase(sender As Object, e As MessageArgs)
|
---|
305 | e.Handled = e.Handled And OnMouseLeave(Args.Empty)
|
---|
306 | mouseEntered = False
|
---|
307 | End Sub
|
---|
308 |
|
---|
309 | Sub OnMouseHoverBase(sender As Object, e As MessageArgs)
|
---|
310 | Dim me = makeMouseEventFromMsg(e)
|
---|
311 | e.Handled = e.Handled And OnMouseHover(me)
|
---|
312 | End Sub
|
---|
313 |
|
---|
314 | Sub OnPaintBase(sender As Object, e As MessageArgs)
|
---|
315 | If ActiveBasic.IsNothing(paintDC) Then
|
---|
316 | e.Handled = False
|
---|
317 | Else
|
---|
318 | Dim ps As PAINTSTRUCT
|
---|
319 | BeginPaint(hwnd, ps)
|
---|
320 | Try
|
---|
321 | OnPaintDC(New PaintDCArgs(ps.hdc, ps.rcPaint))
|
---|
322 | Finally
|
---|
323 | EndPaint(hwnd, ps)
|
---|
324 | End Try
|
---|
325 | End If
|
---|
326 | End Sub
|
---|
327 |
|
---|
328 | Sub OnKeyDownBase(sender As Object, e As MessageArgs)
|
---|
329 | e.Handled = e.Handled And OnKeyDown(New KeyArgs(makeKeysFormMsg(e)))
|
---|
330 | End Sub
|
---|
331 |
|
---|
332 | Sub OnKeyUpBase(sender As Object, e As MessageArgs)
|
---|
333 | e.Handled = e.Handled And OnKeyUp(New KeyArgs(makeKeysFormMsg(e)))
|
---|
334 | End Sub
|
---|
335 |
|
---|
336 | Sub OnChar(sender As Object, e As MessageArgs)
|
---|
337 | e.Handled = e.Handled And OnKeyPress(New KeyPressArgs(e.WParam As Char))
|
---|
338 | End Sub
|
---|
339 |
|
---|
340 | Sub OnCreateBase(sender As Object, e As MessageArgs)
|
---|
341 | e.Handled = e.Handled And OnCreate(New CreateArgs(e.LParam As *CREATESTRUCT))
|
---|
342 | End Sub
|
---|
343 |
|
---|
344 | Sub OnSize(sender As Object, e As MessageArgs)
|
---|
345 | e.Handled = e.Handled And OnResize(New ResizeArgs(e.WParam, e.LParam))
|
---|
346 | End Sub
|
---|
347 |
|
---|
348 | messageMap As System.Collections.Generic.Dictionary<Object /*DWord*/, MessageHandler>
|
---|
349 |
|
---|
350 | Public
|
---|
351 | /*!
|
---|
352 | @biref メッセージイベントハンドラを登録する。
|
---|
353 | @date 2007/12/04
|
---|
354 | */
|
---|
355 | Sub AddMessageEvent(message As DWord, h As MessageHandler)
|
---|
356 | If Not IsNothing(h) Then
|
---|
357 | If IsNothing(messageMap) Then
|
---|
358 | messageMap = New System.Collections.Generic.Dictionary<Object, MessageHandler>
|
---|
359 | End If
|
---|
360 | Dim msg = Hex$(message)
|
---|
361 | Dim m = Nothing As MessageHandler
|
---|
362 | If messageMap.TryGetValue(msg, m) Then
|
---|
363 | messageMap.Item[msg] = m + h
|
---|
364 | Else
|
---|
365 | messageMap.Item[msg] = h
|
---|
366 | End If
|
---|
367 | End If
|
---|
368 | End Sub
|
---|
369 |
|
---|
370 | /*!
|
---|
371 | @biref メッセージイベントハンドラ登録を解除する。
|
---|
372 | @date 2007/12/04
|
---|
373 | */
|
---|
374 | Sub RemoveMessageEvent(message As DWord, a As MessageHandler)
|
---|
375 | If Not IsNothing(a) Then
|
---|
376 | If Not IsNothing(messageMap) Then
|
---|
377 | Dim msg = Hex$(message)
|
---|
378 | Dim m = messageMap.Item[msg]
|
---|
379 | If Not IsNothing(m) Then
|
---|
380 | messageMap.Item[msg] = m - a
|
---|
381 | End If
|
---|
382 | End If
|
---|
383 | End If
|
---|
384 | End Sub
|
---|
385 |
|
---|
386 | '--------------------------------
|
---|
387 | ' ウィンドウメッセージ処理
|
---|
388 |
|
---|
389 |
|
---|
390 | '--------
|
---|
391 | 'イベント
|
---|
392 |
|
---|
393 | #include "ControlEvent.sbp"
|
---|
394 |
|
---|
395 | '--------------------------------
|
---|
396 | ' インスタンスメンバ変数
|
---|
397 | Private
|
---|
398 | /*!
|
---|
399 | @brief サブクラス化前のウィンドウプロシージャ
|
---|
400 | @date 2008/08/23
|
---|
401 | サブクラス化していなければNULL
|
---|
402 | */
|
---|
403 | prevWndProc As WNDPROC
|
---|
404 | /*!
|
---|
405 | @brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
|
---|
406 | 外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
|
---|
407 | */
|
---|
408 | mouseEntered As Boolean
|
---|
409 | /*!
|
---|
410 | @brief ダブルクリックが起こったかどうかのフラグ
|
---|
411 | Click/MouseClickイベントのために用意している。
|
---|
412 | @date 2008/07/12
|
---|
413 | */
|
---|
414 | doubleClickFired As Boolean
|
---|
415 |
|
---|
416 | '--------------------------------
|
---|
417 | ' 初期ウィンドウクラス
|
---|
418 | Protected
|
---|
419 | Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
420 | Imports System.Runtime.InteropServices
|
---|
421 |
|
---|
422 | Dim rThis = FromHWndCore(hwnd)
|
---|
423 | If IsNothing(rThis) Then
|
---|
424 | rThis = _System_PtrObj(TlsGetValue(tlsIndex)) As Control
|
---|
425 | TlsSetValue(tlsIndex, 0)
|
---|
426 | If IsNothing(rThis) Then
|
---|
427 | Goto *InstanceIsNotFound
|
---|
428 | End If
|
---|
429 | ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
|
---|
430 | rThis.AssociateHWnd(hwnd)
|
---|
431 | End If
|
---|
432 | If msg = WM_NCDESTROY Then
|
---|
433 | rThis.UnassociateHWnd()
|
---|
434 | rThis.hwnd = 0
|
---|
435 | End If
|
---|
436 | If msg = WM_DESTROY And IsNothing(rThis.finalDestroy) = False Then
|
---|
437 | Dim f = rThis.finalDestroy
|
---|
438 | f(rThis, Args.Empty)
|
---|
439 | End If
|
---|
440 | WndProcFirst = rThis.WndProc(msg, wp, lp)
|
---|
441 | Exit Function
|
---|
442 |
|
---|
443 | *InstanceIsNotFound
|
---|
444 | Dim err = String.Concat("Control.WndProcFirst: The attached instance is not found. msg = &h",
|
---|
445 | Hex$(msg), Ex"\r\n")
|
---|
446 | OutputDebugString(ToTCStr(err))
|
---|
447 | WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
|
---|
448 | End Function
|
---|
449 |
|
---|
450 | /*!
|
---|
451 | @brief Controlインスタンスとウィンドウハンドルを結び付ける。
|
---|
452 | @param[in] hwndNew 結び付けるウィンドウハンドル
|
---|
453 | @date 2008/07/16
|
---|
454 | これを実行することで、UnassociateHWndされるまでControlがGC対象にならなくなると共に、
|
---|
455 | FromHWndでウィンドウハンドルからControlインスタンスの取得が可能となる。
|
---|
456 | */
|
---|
457 | Sub AssociateHWnd(hwndNew As HWND)
|
---|
458 | SetHWnd(hwndNew)
|
---|
459 | Prop[PropertyInstance] = ObjPtr(This) As HANDLE
|
---|
460 | comImpl.AddRef()
|
---|
461 | End Sub
|
---|
462 |
|
---|
463 | /*!
|
---|
464 | @brief オーナーの破棄時にこのControlインスタンスとウィンドウハンドルの結び付けを解除するよう登録する。
|
---|
465 | @param[in] owner 結び付けの解除を連動させるControl
|
---|
466 | @date 2008/07/16
|
---|
467 | ownerのFinalDestoryでこのControlとHWNDとの結び付けを解除する。
|
---|
468 | */
|
---|
469 | Sub RegisterUnassociateHWnd(owner As Control)
|
---|
470 | If IsNothing(owner) = False Then
|
---|
471 | Dim e = New Handler(AddressOf(UnassociateHWndOnEvent))
|
---|
472 | If IsNothing(finalDestroy) Then
|
---|
473 | owner.finalDestroy = e
|
---|
474 | Else
|
---|
475 | owner.finalDestroy += e
|
---|
476 | End If
|
---|
477 | End If
|
---|
478 | End Sub
|
---|
479 |
|
---|
480 | Sub UnassociateHWndOnEvent(sender As Object, e As Args)
|
---|
481 | UnassociateHWnd()
|
---|
482 | hwnd = 0
|
---|
483 | End Sub
|
---|
484 |
|
---|
485 | Sub UnassociateHWnd()
|
---|
486 | comImpl.Release()
|
---|
487 | End Sub
|
---|
488 |
|
---|
489 | ' Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
|
---|
490 | ' Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord
|
---|
491 |
|
---|
492 | '--------------------------------
|
---|
493 | ' インタフェース実装
|
---|
494 |
|
---|
495 | Public
|
---|
496 | Virtual Function QueryInterfaceImpl(ByRef iid As IID, ByRef pv As VoidPtr) As HRESULT
|
---|
497 | QueryInterfaceImpl = E_NOTIMPL
|
---|
498 | End Function
|
---|
499 |
|
---|
500 | Private
|
---|
501 | /*!
|
---|
502 | @brief ウィンドウの寿命管理
|
---|
503 | Controlには次のAddRef-Releaseの対がある。
|
---|
504 | @li createImpl - WM_NCDESTROY(ウィンドウプロシージャがWndProcFirstの場合)
|
---|
505 | @li createImpl - UnassociateHWnd←UnassociateHWndOnEvent←RegisterUnassociateHWnd(その他のウィンドウクラスの場合)
|
---|
506 | @li Attach - WM_NCDESTROY(サブクラス化された場合)
|
---|
507 | なお、Control派生クラスをサブクラス化すると、後ろ2つが両方適用される。
|
---|
508 | */
|
---|
509 | comImpl As COM.ComClassDelegationImpl
|
---|
510 |
|
---|
511 | '--------------------------------
|
---|
512 | ' その他の補助関数
|
---|
513 | Private
|
---|
514 | Function trackMouseEvent(flags As DWord) As BOOL
|
---|
515 | If pTrackMouseEvent <> 0 Then
|
---|
516 | Dim tme As TRACKMOUSEEVENT
|
---|
517 | With tme
|
---|
518 | .cbSize = Len(tme)
|
---|
519 | .dwFlags = flags
|
---|
520 | .hwndTrack = hwnd
|
---|
521 | .dwHoverTime = HOVER_DEFAULT
|
---|
522 | End With
|
---|
523 | trackMouseEvent = pTrackMouseEvent(tme)
|
---|
524 | End If
|
---|
525 | End Function
|
---|
526 |
|
---|
527 | '--------------------------------
|
---|
528 | ' 初期化終了関連(特にウィンドウクラス)
|
---|
529 | Private
|
---|
530 | 'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
|
---|
531 | Static tlsIndex As DWord
|
---|
532 |
|
---|
533 | Static hInstance As HINSTANCE
|
---|
534 | Static atom As ATOM
|
---|
535 | Static hmodComctl As HMODULE
|
---|
536 | Static pTrackMouseEvent As Detail.PTrackMouseEvent
|
---|
537 |
|
---|
538 | Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
|
---|
539 | Static Const PropertyInstance = 0 As ATOM
|
---|
540 | Public
|
---|
541 | Static Sub Initialize(hinst As HINSTANCE)
|
---|
542 | tlsIndex = TlsAlloc()
|
---|
543 | If tlsIndex = TLS_OUT_OF_INDEXES Then
|
---|
544 | ThrowWithLastError("Control.Initialize: TlsAlloc failed.")
|
---|
545 | End If
|
---|
546 | hInstance = hinst
|
---|
547 | hmodComctl = LoadLibrary("comctl32.dll")
|
---|
548 | pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent")) As Detail.PTrackMouseEvent
|
---|
549 |
|
---|
550 | Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
|
---|
551 | PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))
|
---|
552 | If PropertyInstance = 0 Then
|
---|
553 | ThrowWithLastError("Control.Initialize: GlobalAddAtom failed.")
|
---|
554 | End If
|
---|
555 |
|
---|
556 | Dim wcx As WNDCLASSEX
|
---|
557 | With wcx
|
---|
558 | .cbSize = Len (wcx)
|
---|
559 | .style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
|
---|
560 | .lpfnWndProc = AddressOf (WndProcFirst)
|
---|
561 | .cbClsExtra = 0
|
---|
562 | .cbWndExtra = 0
|
---|
563 | .hInstance = hinst
|
---|
564 | .hIcon = 0
|
---|
565 | .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
|
---|
566 | .hbrBackground = 0
|
---|
567 | .lpszMenuName = 0
|
---|
568 | .lpszClassName = ToTCStr(WindowClassName)
|
---|
569 | .hIconSm = 0
|
---|
570 | End With
|
---|
571 | atom = RegisterClassEx(wcx)
|
---|
572 | If atom = 0 Then
|
---|
573 | ThrowWithLastErrorNT("Control.Initialize: RegisterClasseEx failed.")
|
---|
574 | End If
|
---|
575 | End Sub
|
---|
576 |
|
---|
577 | Static Sub Uninitialize()
|
---|
578 | If atom <> 0 Then
|
---|
579 | UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
|
---|
580 | End If
|
---|
581 | If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
|
---|
582 | TlsFree(tlsIndex)
|
---|
583 | End If
|
---|
584 | If hmodComctl <> 0 Then
|
---|
585 | FreeLibrary(hmodComctl)
|
---|
586 | End If
|
---|
587 | If PropertyInstance <> 0 Then
|
---|
588 | GlobalDeleteAtom(PropertyInstance)
|
---|
589 | End If
|
---|
590 | End Sub
|
---|
591 | End Class
|
---|
592 |
|
---|
593 | /*!
|
---|
594 | @brief WM_COMMANDで通知を行うコントロールの基底クラス
|
---|
595 | @date 2008/08/28
|
---|
596 | @auther Egtra
|
---|
597 | 親がWM_COMMANDを受け取ったら、RaiseCommandEventを呼ぶことを意図している。
|
---|
598 | (Formで実装済み)
|
---|
599 | */
|
---|
600 | Class WmCommandControl
|
---|
601 | Inherits Control
|
---|
602 | Public
|
---|
603 | Abstract Function RaiseCommandEvent(notificationCode As Word) As Boolean
|
---|
604 | End Class
|
---|
605 |
|
---|
606 | End Namespace 'UI
|
---|
607 | End Namespace 'Widnows
|
---|
608 | End Namespace 'ActiveBasic
|
---|