[473] | 1 | 'Classes/ActiveBasic/Windows/UI/Control.ab
|
---|
| 2 |
|
---|
| 3 | #require <Classes/ActiveBasic/Windows/UI/Forms/EventArgs.ab>
|
---|
| 4 |
|
---|
| 5 | Namespace ActiveBasic
|
---|
| 6 | Namespace Windows
|
---|
| 7 | Namespace UI
|
---|
| 8 | Namespace Forms
|
---|
| 9 |
|
---|
| 10 | Class Control
|
---|
| 11 | Public
|
---|
| 12 |
|
---|
| 13 | '1
|
---|
| 14 |
|
---|
| 15 | Sub Control()
|
---|
| 16 | End Sub
|
---|
| 17 |
|
---|
| 18 | Virtual Sub ~Control()
|
---|
| 19 | End Sub
|
---|
| 20 |
|
---|
| 21 | Function Handle() As WindowHandle
|
---|
| 22 | Handle = wnd
|
---|
| 23 | End Function
|
---|
| 24 |
|
---|
| 25 | Static Function FromHWnd(hwnd As HWND) As Control
|
---|
| 26 | FromHWnd = Nothing
|
---|
| 27 | If IsWindow(hwnd) Then
|
---|
| 28 | FromHWnd = FromHWndCore(hwnd)
|
---|
| 29 | End If
|
---|
| 30 | End Function
|
---|
| 31 |
|
---|
| 32 | Private
|
---|
| 33 | Static Function FromHWndCore(hwnd As HWND) As Control
|
---|
| 34 | If GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
|
---|
| 35 | Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
|
---|
| 36 | If gchValue <> 0 Then
|
---|
| 37 | Dim gch = System.Runtime.InteropServices.GCHandle.FromIntPtr(gchValue)
|
---|
| 38 | FromHWndCore = gch.Target As Control
|
---|
| 39 | Exit Function
|
---|
| 40 | End If
|
---|
| 41 | End If
|
---|
| 42 | End Function
|
---|
| 43 |
|
---|
| 44 | '--------------------------------
|
---|
| 45 | ' 1 ウィンドウ作成
|
---|
| 46 | /*
|
---|
| 47 | Function Create(
|
---|
| 48 | parent As HWND,
|
---|
| 49 | rect As RECT,
|
---|
| 50 | name As String,
|
---|
| 51 | style As DWord,
|
---|
| 52 | exStyle = 0 As DWord,
|
---|
| 53 | menu = 0 As HMENU) As HWND
|
---|
| 54 | */
|
---|
| 55 | Public
|
---|
| 56 | Function Create() As Boolean
|
---|
| 57 | Dim cs As CREATESTRUCT
|
---|
| 58 | cs.hInstance = hInstance
|
---|
| 59 | cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
|
---|
| 60 | GetCreateStruct(cs)
|
---|
| 61 | Create = createImpl(cs)
|
---|
| 62 | End Function
|
---|
| 63 |
|
---|
| 64 | Protected
|
---|
| 65 | Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
|
---|
| 66 |
|
---|
| 67 | Function createImpl(ByRef cs As CREATESTRUCT) As Boolean
|
---|
| 68 | Imports System.Runtime.InteropServices
|
---|
| 69 |
|
---|
| 70 | Dim gch = GCHandle.Alloc(This)
|
---|
| 71 | TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)
|
---|
| 72 |
|
---|
| 73 | With cs
|
---|
| 74 | Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
|
---|
| 75 | .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
|
---|
| 76 | createImpl = hwnd <> 0
|
---|
| 77 | End With
|
---|
| 78 | End Function
|
---|
| 79 |
|
---|
| 80 | '--------------------------------
|
---|
| 81 | ' ウィンドウプロシージャ
|
---|
| 82 | 'Protected
|
---|
| 83 | Public
|
---|
| 84 | Virtual Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
| 85 | Select Case msg
|
---|
| 86 | Case WM_ERASEBKGND
|
---|
| 87 | Dim rc = wnd.ClientRect
|
---|
| 88 | Dim e = New PaintDCHandledEventArgs(wp As HDC, rc)
|
---|
| 89 | OnPaintBackground(e)
|
---|
| 90 | WndProc = e.Handled
|
---|
| 91 | Case WM_PAINT
|
---|
| 92 | Dim ps As PAINTSTRUCT
|
---|
| 93 | wnd.BeginPaint(ps)
|
---|
| 94 | Try
|
---|
| 95 | Dim e = New PaintDCEventArgs(ps.hdc, ps.rcPaint)
|
---|
| 96 | OnPaintDC(e)
|
---|
| 97 | Finally
|
---|
| 98 | wnd.EndPaint(ps)
|
---|
| 99 | End Try
|
---|
| 100 | Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN, WM_XBUTTONDOWN
|
---|
| 101 | OnMouseDown(New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0))
|
---|
| 102 | Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP, WM_XBUTTONUP
|
---|
| 103 | OnMouseUp(New MouseEventArgs(LOWORD(wp) As MouseButtons, 1, GET_X_LPARAM(lp), GET_Y_LPARAM(lp), 0))
|
---|
| 104 | /*
|
---|
| 105 | Case WM_KEYDOWN
|
---|
| 106 | OnKeyDown(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
|
---|
| 107 | Case WM_KEYUP
|
---|
| 108 | OnKeyUp(New KeyEventArgs(makeKeysFormWPLP(wp, lp)))
|
---|
| 109 | Case WM_CHAR
|
---|
| 110 | OnKeyPress(New KeyPressEventArgs(wParam As Char))
|
---|
| 111 | Case WM_ENABLE
|
---|
| 112 | OnEnableChanged(EventArgs.Empty)
|
---|
| 113 | Case WM_MOVE
|
---|
| 114 | OnMove(EventArgs.Empty)
|
---|
| 115 | Case WM_SIZE
|
---|
| 116 | OnResize(EventArgs.Empty)
|
---|
| 117 | */
|
---|
| 118 | Case Else
|
---|
| 119 | WndProc = DefWndProc(msg, wp, lp)
|
---|
| 120 | End Select
|
---|
| 121 | End Function
|
---|
| 122 |
|
---|
| 123 | Virtual Function DefWndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
| 124 | DefWndProc = DefWindowProc(wnd.HWnd, msg, wp, lp)
|
---|
| 125 | End Function
|
---|
| 126 |
|
---|
| 127 | Private
|
---|
| 128 | Function makeKeysFormWPLP(wp As WPARAM, lp As LPARAM) As Keys
|
---|
| 129 | Dim t As DWord
|
---|
| 130 | t = wp And Keys.KeyCode
|
---|
| 131 | t Or= (GetKeyState(VK_SHIFT) As Word And &h8000) << 1
|
---|
| 132 | t Or= (GetKeyState(VK_CONTROL) As Word And &h8000) << 2
|
---|
| 133 | t Or= (GetKeyState(VK_MENU) As Word And &h8000) << 3
|
---|
| 134 | makeKeysFormWPLP = t As Keys
|
---|
| 135 | End Function
|
---|
| 136 |
|
---|
| 137 |
|
---|
| 138 | '--------------------------------
|
---|
| 139 | ' ウィンドウメッセージ処理
|
---|
| 140 |
|
---|
| 141 | '--------
|
---|
| 142 | ' 2
|
---|
| 143 |
|
---|
| 144 | Protected
|
---|
| 145 | /*!
|
---|
| 146 | @biref ウィンドウの背景を描画する。
|
---|
| 147 | @date 2007/12/04
|
---|
| 148 | */
|
---|
| 149 | Virtual Sub OnPaintBackground(e As PaintDCBackGroundEventArgs)
|
---|
| 150 | Dim hbr = (COLOR_3DFACE + 1) As HBRUSH
|
---|
| 151 | FillRect(e.Handle, e.ClipRect, hbr)
|
---|
| 152 | e.Handled = True
|
---|
| 153 | End Sub
|
---|
| 154 |
|
---|
| 155 | '--------
|
---|
| 156 | 'イベント
|
---|
| 157 | ' 3
|
---|
| 158 |
|
---|
| 159 | #include "ControlEvent.sbp"
|
---|
| 160 |
|
---|
| 161 | '--------------------------------
|
---|
| 162 | ' 1 インスタンスメンバ変数
|
---|
| 163 | Private
|
---|
| 164 | wnd As WindowHandle
|
---|
| 165 |
|
---|
| 166 | '--------------------------------
|
---|
| 167 | ' 1 初期ウィンドウクラス
|
---|
| 168 | Private
|
---|
| 169 | Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
| 170 | Imports System.Runtime.InteropServices
|
---|
| 171 |
|
---|
| 172 | Dim rThis = Control.FromHWndCore(hwnd)
|
---|
| 173 | If IsNothing(rThis) Then
|
---|
| 174 | Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
|
---|
| 175 | TlsSetValue(tlsIndex, 0)
|
---|
| 176 | If gchValue = 0 Then
|
---|
| 177 | Goto *InstanceIsNotFound
|
---|
| 178 | End If
|
---|
| 179 | Dim gch = GCHandle.FromIntPtr(gchValue)
|
---|
| 180 | rThis = gch.Target As Control
|
---|
| 181 | ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
|
---|
| 182 |
|
---|
| 183 | If IsNothing(rThis) Then
|
---|
| 184 | Goto *InstanceIsNotFound
|
---|
| 185 | End If
|
---|
| 186 | rThis.wnd = New WindowHandle(hwnd)
|
---|
| 187 | rThis.wnd.SetProp(PropertyInstance, gchValue As HANDLE)
|
---|
| 188 | End If
|
---|
| 189 | WndProcFirst = rThis.WndProc(msg, wp, lp)
|
---|
| 190 | If msg = WM_NCDESTROY Then
|
---|
| 191 | Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
|
---|
| 192 | If gchValue <> 0 Then
|
---|
| 193 | Dim gch = GCHandle.FromIntPtr(gchValue)
|
---|
| 194 | gch.Free()
|
---|
| 195 | End If
|
---|
| 196 | End If
|
---|
| 197 |
|
---|
| 198 | Exit Function
|
---|
| 199 |
|
---|
| 200 | *InstanceIsNotFound
|
---|
| 201 | OutputDebugString("ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.")
|
---|
| 202 | WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
|
---|
| 203 | End Function
|
---|
| 204 |
|
---|
| 205 | ' Static Const WM_CONTROL_INVOKE = WM_USER + 0 As DWord
|
---|
| 206 | ' Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord
|
---|
| 207 |
|
---|
| 208 | '--------------------------------
|
---|
| 209 | ' 1 初期化終了関連(特にウィンドウクラス)
|
---|
| 210 |
|
---|
| 211 | 'ウィンドウ作成時にウィンドウプロシージャへThisを伝えるためのもの
|
---|
| 212 | Static tlsIndex As DWord
|
---|
| 213 |
|
---|
| 214 | Static hInstance As HINSTANCE
|
---|
| 215 | Static atom As ATOM
|
---|
| 216 |
|
---|
| 217 | Static Const WindowClassName = "ActiveBasic.Windows.UI.Control"
|
---|
| 218 | Static Const PropertyInstance = 0 As ATOM
|
---|
| 219 | Public
|
---|
| 220 | Static Sub Initialize(hinst As HINSTANCE)
|
---|
| 221 | tlsIndex = TlsAlloc()
|
---|
| 222 | hInstance = hinst
|
---|
| 223 |
|
---|
| 224 | Dim PropertyInstanceString = WindowClassName + " " + Hex$(GetCurrentProcessId())
|
---|
| 225 | PropertyInstance = GlobalAddAtom(ToTCStr(PropertyInstanceString))
|
---|
| 226 |
|
---|
| 227 | Dim wcx As WNDCLASSEX
|
---|
| 228 | With wcx
|
---|
| 229 | .cbSize = Len (wcx)
|
---|
| 230 | .style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
|
---|
| 231 | .lpfnWndProc = AddressOf (WndProcFirst)
|
---|
| 232 | .cbClsExtra = 0
|
---|
| 233 | .cbWndExtra = 0
|
---|
| 234 | .hInstance = hinst
|
---|
| 235 | .hIcon = 0
|
---|
| 236 | .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
|
---|
| 237 | .hbrBackground = 0
|
---|
| 238 | .lpszMenuName = 0
|
---|
| 239 | .lpszClassName = ToTCStr(WindowClassName)
|
---|
| 240 | .hIconSm = 0
|
---|
| 241 | End With
|
---|
| 242 | atom = RegisterClassEx(wcx)
|
---|
| 243 | If atom = 0 Then
|
---|
| 244 | Dim buf[1023] As TCHAR
|
---|
| 245 | wsprintf(buf, Ex"ActiveBasic.Windows.UI.Control.Control: RegisterClasseEx failed. Error code: &h%08X\r\n", GetLastError())
|
---|
| 246 | OutputDebugString(buf)
|
---|
| 247 | Debug
|
---|
| 248 | ExitThread(0)
|
---|
| 249 | End If
|
---|
| 250 | End Sub
|
---|
| 251 |
|
---|
| 252 | Static Sub Uninitialize()
|
---|
| 253 | UnregisterClass(atom As ULONG_PTR As PCSTR, hInstance)
|
---|
| 254 | TlsFree(tlsIndex)
|
---|
| 255 | GlobalDeleteAtom(PropertyInstance)
|
---|
| 256 | End Sub
|
---|
| 257 | End Class
|
---|
| 258 |
|
---|
| 259 | Namespace Detail
|
---|
| 260 | Class _System_ControlIinitializer
|
---|
| 261 | Public
|
---|
| 262 | Sub _System_ControlIinitializer(hinst As HINSTANCE)
|
---|
| 263 | Control.Initialize(hinst)
|
---|
| 264 | End Sub
|
---|
| 265 |
|
---|
| 266 | Sub ~_System_ControlIinitializer()
|
---|
| 267 | Control.Uninitialize()
|
---|
| 268 | End Sub
|
---|
| 269 | End Class
|
---|
| 270 |
|
---|
| 271 | #ifndef _SYSTEM_NO_INITIALIZE_CONTROL_
|
---|
| 272 | Dim _System_ControlInitializer As _System_ControlIinitializer(GetModuleHandle(0))
|
---|
| 273 | #endif '_SYSTEM_NO_INITIALIZE_CONTROL_
|
---|
| 274 |
|
---|
| 275 | End Namespace 'Detail
|
---|
| 276 |
|
---|
| 277 | Class Form
|
---|
| 278 | Inherits Control
|
---|
| 279 | Protected
|
---|
| 280 | Override Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
|
---|
| 281 | With cs
|
---|
| 282 | .lpCreateParams = 0
|
---|
| 283 | '.hInstance
|
---|
| 284 | .hMenu = 0
|
---|
| 285 | .hwndParent = 0
|
---|
| 286 | .cy = CW_USEDEFAULT
|
---|
| 287 | .cx = CW_USEDEFAULT
|
---|
| 288 | .y = CW_USEDEFAULT
|
---|
| 289 | .x = CW_USEDEFAULT
|
---|
| 290 | .style = WS_OVERLAPPEDWINDOW
|
---|
| 291 | .lpszName = ""
|
---|
| 292 | '.lpszClass
|
---|
| 293 | .dwExStyle = 0
|
---|
| 294 | End With
|
---|
| 295 | End Sub
|
---|
| 296 | Public '仮
|
---|
| 297 | Override Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
|
---|
| 298 | WndProc = 0
|
---|
| 299 | Select Case msg
|
---|
| 300 | Case WM_DESTROY
|
---|
| 301 | PostQuitMessage(0)
|
---|
| 302 | Case Else
|
---|
| 303 | WndProc = Super.WndProc(msg, wp, lp)
|
---|
| 304 | End Select
|
---|
| 305 | End Function
|
---|
| 306 | End Class
|
---|
| 307 |
|
---|
| 308 | End Namespace 'Forms
|
---|
| 309 | End Namespace 'UI
|
---|
| 310 | End Namespace 'Widnows
|
---|
| 311 | End Namespace 'ActiveBasic
|
---|
| 312 |
|
---|
| 313 | '----------
|
---|
| 314 | 'テスト実行用
|
---|
| 315 |
|
---|
| 316 | Imports ActiveBasic.Windows.UI.Forms
|
---|
| 317 |
|
---|
| 318 | Class Bar
|
---|
| 319 | Public
|
---|
| 320 | Static Sub PaintDCEvent(sender As Object, et As PaintDCEventArgs)
|
---|
| 321 | Dim e = et As PaintDCEventArgs
|
---|
| 322 | TextOut(e.Handle, 10, 10, "Hello, world", 12)
|
---|
| 323 | End Sub
|
---|
| 324 | End Class
|
---|
| 325 |
|
---|
| 326 | Dim f = New Form
|
---|
| 327 | f.Create()
|
---|
| 328 | Dim v = New PaintDCEventHandler(AddressOf (Bar.PaintDCEvent))
|
---|
| 329 | f.AddPaintDC(v)
|
---|
| 330 | f.Handle.Show(SW_SHOW)
|
---|
| 331 |
|
---|
| 332 | MessageBox(0, "hello", "", 0)
|
---|