| 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)
|
|---|
