1 | 'Classes/ActiveBasic/Windows/UI/Control.ab
|
---|
2 |
|
---|
3 | #require <Classes/ActiveBasic/Windows/UI/EventArgs.ab>
|
---|
4 |
|
---|
5 | Namespace ActiveBasic
|
---|
6 | Namespace Windows
|
---|
7 | Namespace UI
|
---|
8 |
|
---|
9 | 'Namespace Detail
|
---|
10 | ' TypeDef PTrackMouseEvent = *Function(ByRef tme As TRACKMOUSEEVENT) As BOOL
|
---|
11 | 'End Namespace
|
---|
12 |
|
---|
13 | Class Control
|
---|
14 | Inherits WindowHandle
|
---|
15 | Public
|
---|
16 |
|
---|
17 | Sub Control()
|
---|
18 | End Sub
|
---|
19 |
|
---|
20 | Virtual Sub ~Control()
|
---|
21 | End Sub
|
---|
22 |
|
---|
23 | Function Handle() As HWND
|
---|
24 | Handle = hwnd
|
---|
25 | End Function
|
---|
26 |
|
---|
27 | Static Function FromHWnd(hwnd As HWND) As Control
|
---|
28 | FromHWnd = Nothing
|
---|
29 | If _System_IsWindow(hwnd) Then
|
---|
30 | FromHWnd = FromHWndCore(hwnd)
|
---|
31 | End If
|
---|
32 | End Function
|
---|
33 |
|
---|
34 | Private
|
---|
35 | Static Function FromHWndCore(hwnd As HWND) As Control
|
---|
36 | If _System_GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
|
---|
37 | Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
|
---|
38 | If gchValue <> 0 Then
|
---|
39 | Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
|
---|
40 | FromHWndCore = gch.Target As Control
|
---|
41 | Exit Function
|
---|
42 | End If
|
---|
43 | End If
|
---|
44 | End Function
|
---|
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 | Public
|
---|
57 | Sub Create()
|
---|
58 | Dim cs As CREATESTRUCT
|
---|
59 | cs.hInstance = hInstance
|
---|
60 | cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
|
---|
61 | GetCreateStruct(cs)
|
---|
62 | createImpl(cs)
|
---|
63 | End Sub
|
---|
64 |
|
---|
65 | Protected
|
---|
66 | Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
|
---|
67 |
|
---|
68 | Sub createImpl(ByRef cs As CREATESTRUCT)
|
---|
69 | Imports System.Runtime.InteropServices
|
---|
70 |
|
---|
71 | Dim gch = GCHandle.Alloc(This)
|
---|
72 | TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)
|
---|
73 |
|
---|
74 | StartWndProc()
|
---|
75 |
|
---|
76 | With cs
|
---|
77 | Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
|
---|
78 | .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
|
---|
79 | If hwnd = 0 Then
|
---|
80 | ActiveBasic.Windows.ThrowByWindowsError(GetLastError())
|
---|
81 | End If
|
---|
82 | End With
|
---|
83 | End Sub
|
---|
84 |
|
---|
85 | '--------------------------------
|
---|
86 | ' ウィンドウプロシージャ
|
---|
87 | 'Protected
|
---|
88 | Public
|
---|
89 | Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
90 | Dim h = Nothing As MessageEventHandler
|
---|
91 | Dim b = messageMap.TryGetValue(Hex$(msg), h)
|
---|
92 | If b Then
|
---|
93 | If Not IsNothing(h) Then
|
---|
94 | Dim a = New MessageEventArgs(hwnd, msg, wp, lp)
|
---|
95 | h(This, a)
|
---|
96 | WndProc = a.LResult
|
---|
97 | Exit Function
|
---|
98 | End If
|
---|
99 | End If
|
---|
100 | WndProc = DefWndProc(msg, wp, lp)
|
---|
101 | End Function
|
---|
102 |
|
---|
103 | Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
104 | DefWndProc = DefWindowProc(hwnd, msg, wp, lp)
|
---|
105 | End Function
|
---|
106 |
|
---|
107 | Private
|
---|
108 | Static Function makeKeysFormMsg(e As MessageEventArgs) As Keys
|
---|
109 | Dim t As DWord
|
---|
110 | t = e.WParam And Keys.KeyCode
|
---|
111 | t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
|
---|
112 | t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
|
---|
113 | t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
|
---|
114 | makeKeysFormMsg = t As Keys
|
---|
115 | End Function
|
---|
116 |
|
---|
117 | Static Function makeMouseEventFromMsg(e As MessageEventArgs) As MouseEventArgs
|
---|
118 | Dim wp = e.WParam
|
---|
119 | Dim lp = e.LParam
|
---|
120 | makeMouseEventFromMsg = New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0)
|
---|
121 | End Function
|
---|
122 |
|
---|
123 | /*!
|
---|
124 | @brief 最初にウィンドウプロシージャが呼ばれるときに実行される関数
|
---|
125 | ここでは、主なメッセージハンドラの登録を行っている。
|
---|
126 | @date 2008/07/11
|
---|
127 | */
|
---|
128 | Sub StartWndProc()
|
---|
129 | AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
|
---|
130 | Dim md = New MessageEventHandler(AddressOf(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(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(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_MOUSEMOVE, AddressOf(OnMouseMoveBase))
|
---|
147 | AddMessageEvent(WM_MOUSELEAVE, AddressOf(OnMouseLeaveBase))
|
---|
148 | AddMessageEvent(WM_PAINT, AddressOf(OnPaintBase))
|
---|
149 | AddMessageEvent(WM_KEYDOWN, AddressOf(OnKeyDownBase))
|
---|
150 | ' AddMessageEvent(WM_CHAR, AddressOf(OnChar))
|
---|
151 | AddMessageEvent(WM_CREATE, AddressOf(OnCreateBase))
|
---|
152 | End Sub
|
---|
153 |
|
---|
154 | Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
|
---|
155 | Dim rc = ClientRect
|
---|
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(ps)
|
---|
201 | Try
|
---|
202 | OnPaintDC(New PaintDCEventArgs(ps.hdc, ps.rcPaint))
|
---|
203 | Finally
|
---|
204 | EndPaint(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 |
|
---|
227 | Public
|
---|
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 = Hex$(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 | ' インスタンスメンバ変数
|
---|
274 | Private
|
---|
275 | /*!
|
---|
276 | @brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
|
---|
277 | 外から中に入ってきたときにMouseEnterイベントを発生させるために用意している。
|
---|
278 | */
|
---|
279 | mouseEntered As Boolean
|
---|
280 | /*!
|
---|
281 | @brief ダブルクリックが起こったかどうかのフラグ
|
---|
282 | Click/MouseClickイベントのために用意している。
|
---|
283 | @date 2008/07/12
|
---|
284 | */
|
---|
285 | doubleClickFired As Boolean
|
---|
286 |
|
---|
287 | '--------------------------------
|
---|
288 | ' 初期ウィンドウクラス
|
---|
289 | Private
|
---|
290 | Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
291 | Imports System.Runtime.InteropServices
|
---|
292 |
|
---|
293 | Dim rThis = FromHWndCore(hwnd)
|
---|
294 | If IsNothing(rThis) Then
|
---|
295 | Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
|
---|
296 | TlsSetValue(tlsIndex, 0)
|
---|
297 | If gchValue = 0 Then
|
---|
298 | Goto *InstanceIsNotFound
|
---|
299 | End If
|
---|
300 | Dim gch = GCHandle.FromIntPtr(gchValue)
|
---|
301 | rThis = gch.Target As Control
|
---|
302 | ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
|
---|
303 |
|
---|
304 | If IsNothing(rThis) Then
|
---|
305 | Goto *InstanceIsNotFound
|
---|
306 | End If
|
---|
307 | rThis.hwnd = hwnd
|
---|
308 | rThis.Prop[PropertyInstance] = gchValue As HANDLE
|
---|
309 | End If
|
---|
310 | WndProcFirst = rThis.WndProc(msg, wp, lp)
|
---|
311 | If msg = WM_NCDESTROY Then
|
---|
312 | Dim gchValue = rThis.Prop(PropertyInstance) As ULONG_PTR
|
---|
313 | If gchValue <> 0 Then
|
---|
314 | GCHandle.FromIntPtr(gchValue).Free()
|
---|
315 | End If
|
---|
316 | End If
|
---|
317 |
|
---|
318 | Exit Function
|
---|
319 |
|
---|
320 | *InstanceIsNotFound
|
---|
321 | OutputDebugString(Ex"ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.\r\n")
|
---|
322 | WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
|
---|
323 | End Function
|
---|
324 |
|
---|
325 | ' Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
|
---|
326 | ' Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord
|
---|
327 |
|
---|
328 | '--------------------------------
|
---|
329 | ' その他の補助関数
|
---|
330 | Private
|
---|
331 | ' Sub tracMouseEvent()
|
---|
332 | /* If pTrackMouseEvent <> 0 Then
|
---|
333 | Dim tme As TRACKMOUSEEVENT
|
---|
334 | With tme
|
---|
335 | .cbSize = Len(tme)
|
---|
336 | .dwFlags = TME_HOVER Or TME_LEAVE
|
---|
337 | .hwndTrack = wnd
|
---|
338 | .dwHoverTime = HOVER_DEFAULT
|
---|
339 | End With
|
---|
340 | pTrackMouseEvent(tme)
|
---|
341 | End If
|
---|
342 | */ 'End Sub
|
---|
343 |
|
---|
344 | '--------------------------------
|
---|
345 | ' 初期化終了関連(特にウィンドウクラス)
|
---|
346 | Private
|
---|
347 | 'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
|
---|
348 | Static tlsIndex As DWord
|
---|
349 |
|
---|
350 | Static hInstance As HINSTANCE
|
---|
351 | Static atom As ATOM
|
---|
352 | Static hmodComctl As HMODULE
|
---|
353 | ' Static pTrackMouseEvent As PTrackMouseEvent
|
---|
354 |
|
---|
355 | Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
|
---|
356 | Static Const PropertyInstance = 0 As ATOM
|
---|
357 | Public
|
---|
358 | Static Sub Initialize(hinst As HINSTANCE)
|
---|
359 | tlsIndex = TlsAlloc()
|
---|
360 | hInstance = hinst
|
---|
361 | ' hmodComctl = LoadLibrary("comctl32.dll")
|
---|
362 | ' pTrackMouseEvent = GetProcAddress(hmodComctl, ToMBStr("_TrackMouseEvent"))
|
---|
363 |
|
---|
364 | Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
|
---|
365 | PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))
|
---|
366 |
|
---|
367 | Dim wcx As WNDCLASSEX
|
---|
368 | With wcx
|
---|
369 | .cbSize = Len (wcx)
|
---|
370 | .style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
|
---|
371 | .lpfnWndProc = AddressOf (WndProcFirst)
|
---|
372 | .cbClsExtra = 0
|
---|
373 | .cbWndExtra = 0
|
---|
374 | .hInstance = hinst
|
---|
375 | .hIcon = 0
|
---|
376 | .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
|
---|
377 | .hbrBackground = 0
|
---|
378 | .lpszMenuName = 0
|
---|
379 | .lpszClassName = ToTCStr(WindowClassName)
|
---|
380 | .hIconSm = 0
|
---|
381 | End With
|
---|
382 | atom = RegisterClassEx(wcx)
|
---|
383 | If atom = 0 Then
|
---|
384 | Dim buf[1023] As TCHAR
|
---|
385 | wsprintf(buf, Ex"ActiveBasic.Windows.UI.Control.Control: RegisterClasseEx failed. Error code: &h%08X\r\n", GetLastError())
|
---|
386 | OutputDebugString(buf)
|
---|
387 | Debug
|
---|
388 | ExitThread(0)
|
---|
389 | End If
|
---|
390 | End Sub
|
---|
391 |
|
---|
392 | Static Sub Uninitialize()
|
---|
393 | If atom <> 0 Then
|
---|
394 | UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
|
---|
395 | End If
|
---|
396 | If tlsIndex <> 0 And tlsIndex <> &hffffffff Then
|
---|
397 | TlsFree(tlsIndex)
|
---|
398 | End If
|
---|
399 | ' If hmodComctl <> 0 Then
|
---|
400 | ' FreeLibrary(hmodComctl)
|
---|
401 | ' End If
|
---|
402 | If PropertyInstance <> 0 Then
|
---|
403 | GlobalDeleteAtom(PropertyInstance)
|
---|
404 | End If
|
---|
405 | End Sub
|
---|
406 |
|
---|
407 | End Class
|
---|
408 |
|
---|
409 | End Namespace 'UI
|
---|
410 | End Namespace 'Widnows
|
---|
411 | End Namespace 'ActiveBasic
|
---|