Ignore:
Timestamp:
Jul 13, 2008, 11:54:55 PM (16 years ago)
Author:
イグトランス (egtra)
Message:

Applicationクラスの追加

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/UI/Control.ab

    r545 r547  
    1212
    1313Class Control
     14    Inherits WindowHandle
    1415Public
     16
    1517    Sub Control()
    1618    End Sub
    … …  
    2527    Static Function FromHWnd(hwnd As HWND) As Control
    2628        FromHWnd = Nothing
    27         If IsWindow(hwnd) Then
     29        If _System_IsWindow(hwnd) Then
    2830            FromHWnd = FromHWndCore(hwnd)
    2931        End If
    … …  
    3234Private
    3335    Static Function FromHWndCore(hwnd As HWND) As Control
    34         If GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
     36        If _System_GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
    3537            Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
    3638            If gchValue <> 0 Then
    … …  
    4446'--------------------------------
    4547' ウィンドウ作成
    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 */
     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
    5555
    5656Public
    57     Function Create() As Boolean
     57    Sub Create()
    5858        Dim cs As CREATESTRUCT
    5959        cs.hInstance = hInstance
    6060        cs.lpszClass = (atom As ULONG_PTR) As LPCTSTR
    6161        GetCreateStruct(cs)
    62         Create = createImpl(cs)
    63     End Function
     62        createImpl(cs)
     63    End Sub
    6464
    6565Protected
    6666    Abstract Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
    6767
    68     Function createImpl(ByRef cs As CREATESTRUCT) As Boolean
     68    Sub createImpl(ByRef cs As CREATESTRUCT)
    6969        Imports System.Runtime.InteropServices
    7070
    … …  
    7777            Dim hwnd = CreateWindowEx(.dwExStyle, .lpszClass, .lpszName, .style,
    7878                .x, .y, .cx, .cy, .hwndParent, .hMenu, .hInstance, .lpCreateParams)
    79             createImpl = hwnd <> 0
     79            If hwnd = 0 Then
     80                ActiveBasic.Windows.ThrowByWindowsError(GetLastError())
     81            End If
    8082        End With
    81     End Function
     83    End Sub
    8284
    8385'--------------------------------
    … …  
    125127    */
    126128    Sub StartWndProc()
    127         Dim t = This '#177対策
    128         AddMessageEvent(WM_ERASEBKGND, AddressOf(t.OnEraseBackground))
    129         Dim md = New MessageEventHandler(AddressOf(t.OnMouseDownBase))
     129        AddMessageEvent(WM_ERASEBKGND, AddressOf(OnEraseBackground))
     130        Dim md = New MessageEventHandler(AddressOf(OnMouseDownBase))
    130131        AddMessageEvent(WM_LBUTTONDOWN, md)
    131132        AddMessageEvent(WM_RBUTTONDOWN, md)
    132133        AddMessageEvent(WM_MBUTTONDOWN, md)
    133134        AddMessageEvent(WM_XBUTTONDOWN, md)
    134         Dim mu = New MessageEventHandler(AddressOf(t.OnMouseUpBase))
     135        Dim mu = New MessageEventHandler(AddressOf(OnMouseUpBase))
    135136        AddMessageEvent(WM_LBUTTONUP, mu)
    136137        AddMessageEvent(WM_RBUTTONUP, mu)
    137138        AddMessageEvent(WM_MBUTTONUP, mu)
    138139        AddMessageEvent(WM_XBUTTONUP, mu)
    139         Dim mb = New MessageEventHandler(AddressOf(t.OnMouseDblClkBase))
     140        Dim mb = New MessageEventHandler(AddressOf(OnMouseDblClkBase))
    140141        AddMessageEvent(WM_LBUTTONDBLCLK, mu)
    141142        AddMessageEvent(WM_RBUTTONDBLCLK, mu)
    … …  
    143144        AddMessageEvent(WM_XBUTTONDBLCLK, mu)
    144145
    145         AddMessageEvent(WM_MOUSELEAVE, AddressOf(t.OnMouseLeaveBase))
    146         AddMessageEvent(WM_PAINT, AddressOf(t.OnPaintBase))
    147         AddMessageEvent(WM_KEYDOWN, AddressOf(t.OnKeyDownBase))
    148 '       AddMessageEvent(WM_CHAR, AddressOf(t.OnChar))   
    149         AddMessageEvent(WM_CREATE, AddressOf(t.OnCreateBase))
     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))
    150152    End Sub
    151153
    152154    Sub OnEraseBackground(sender As Object, e As MessageEventArgs)
    153         Dim rc As RECT
    154         Dim r = GetClientRect(hwnd, rc)
     155        Dim rc = ClientRect
    155156        FillRect(e.WParam As HDC, rc, (COLOR_3DFACE + 1) As HBRUSH)
    156157        e.LResult = TRUE
    … …  
    197198    Sub OnPaintBase(sender As Object, e As MessageEventArgs)
    198199        Dim ps As PAINTSTRUCT
    199         BeginPaint(hwnd, ps)
     200        BeginPaint(ps)
    200201        Try
    201202            OnPaintDC(New PaintDCEventArgs(ps.hdc, ps.rcPaint))
    202203        Finally
    203             EndPaint(hwnd, ps)
     204            EndPaint(ps)
    204205        End Try
    205206    End Sub
    … …  
    272273' インスタンスメンバ変数
    273274Private
    274     hwnd As HWND
    275275    /*!
    276276    @brief マウスカーソルがクライアント領域に入っているかどうかのフラグ
    … …  
    291291        Imports System.Runtime.InteropServices
    292292
    293         Dim rThis = Control.FromHWndCore(hwnd)
     293        Dim rThis = FromHWndCore(hwnd)
    294294        If IsNothing(rThis) Then
    295295            Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
    … …  
    306306            End If
    307307            rThis.hwnd = hwnd
    308             SetProp(hwnd, PropertyInstance As ULONG_PTR As PCSTR, gchValue As HANDLE)
     308            rThis.Prop[PropertyInstance] = gchValue As HANDLE
    309309        End If
    310310        WndProcFirst = rThis.WndProc(msg, wp, lp)
    311311        If msg = WM_NCDESTROY Then
    312             Dim gchValue = GetProp(hwnd, PropertyInstance As ULONG_PTR As PCTSTR) As ULONG_PTR
     312            Dim gchValue = rThis.Prop(PropertyInstance) As ULONG_PTR
    313313            If gchValue <> 0 Then
    314                 Dim gch = GCHandle.FromIntPtr(gchValue)
    315                 gch.Free()
     314                GCHandle.FromIntPtr(gchValue).Free()
    316315            End If
    317316        End If
    … …  
    320319
    321320    *InstanceIsNotFound
    322         OutputDebugString("ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.")
     321        OutputDebugString(Ex"ActiveBasic.Windows.UI.Control.WndProcFirst: The attached instance is not found.\r\n")
    323322        WndProcFirst = DefWindowProc(hwnd, msg, wp, lp)
    324323    End Function
    … …  
    408407End Class
    409408
    410 Class Form '仮
    411     Inherits Control
    412 Protected
    413     Override Sub GetCreateStruct(ByRef cs As CREATESTRUCT)
    414         With cs
    415             .lpCreateParams = 0
    416             '.hInstance
    417             .hMenu = 0
    418             .hwndParent = 0
    419             .cy = CW_USEDEFAULT
    420             .cx = CW_USEDEFAULT
    421             .y = CW_USEDEFAULT
    422             .x = CW_USEDEFAULT
    423             .style = WS_OVERLAPPEDWINDOW
    424             .lpszName = ""
    425             '.lpszClass
    426             .dwExStyle = 0
    427         End With
    428     End Sub
    429 Public
    430 
    431     Override Function WndProc(msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
    432         WndProc = 0
    433         Select Case msg
    434             Case Else
    435                 WndProc = Super.WndProc(msg, wp, lp)
    436         End Select
    437     End Function
    438 End Class
    439 
    440409End Namespace 'UI
    441410End Namespace 'Widnows
    442411End Namespace 'ActiveBasic
    443 
    444 '----------
    445 'テスト実行用
    446 
    447 Imports ActiveBasic.Windows.UI
    448 
    449 'OleInitialize()
    450 Control.Initialize(GetModuleHandle(0))
    451 
    452 Class MyForm
    453     Inherits Form
    454 Public
    455     Sub MyForm()
    456         Dim f = This
    457         f.AddMessageEvent(WM_DESTROY, AddressOf (f.Destory))
    458         f.AddPaintDC(AddressOf (f.Paint))
    459     End Sub
    460 
    461     Sub Destory(sender As Object, e As EventArgs)
    462         OutputDebugString(Ex"Destory\r\n")
    463         PostQuitMessage(0)
    464     End Sub
    465 
    466     Sub Paint(sender As Object, e As PaintDCEventArgs)
    467         TextOut(e.Handle, 10, 10, "Hello world!", 12)
    468     End Sub
    469 End Class
    470 
    471 Dim f = New MyForm
    472 f.Create()
    473 ShowWindow(f.Handle, SW_SHOW)
    474 
    475 Dim m As MSG
    476 Do
    477     Dim ret = GetMessage(m, 0, 0, 0)
    478     If ret = 0 Then
    479         Exit Do
    480     ElseIf ret = -1 Then
    481         ExitProcess(-1)
    482     End If
    483 
    484     TranslateMessage(m)
    485     DispatchMessage(m)
    486 Loop
    487 
    488 f = Nothing
    489 System.GC.Collect()
    490 
    491 Control.Uninitialize()
    492 'OleUninitialize()
    493 
    494 End
Note: See TracChangeset for help on using the changeset viewer.