Ignore:
Timestamp:
Apr 30, 2007, 1:56:57 PM (17 years ago)
Author:
イグトランス (egtra)
Message:

Controlがコンパイルできるように修正

File:
1 edited

Legend:

Unmodified
Added
Removed

  • Include/Classes/System/Windows/Forms/Control.ab

    r132 r223  
    44#define __SYSTEM_WINDOWS_FORMS_CONTROL_AB__
    55
    6 #include <windows/WindowHandle.sbp>
    7 #include <Classes/System/Windows/Forms/misc.ab>
    8 #include <Classes/System/Windows/Forms/CreateParams.ab>
    9 #include <Classes/System/Windows/Forms/Message.ab>
    10 #include <Classes/System/Windows/Forms/PaintEventArgs.ab>
    11 #include <Classes/System/misc.ab>
    12 #include <Classes/System/Math.ab>
    13 #include <Classes/System/Threading/WaitHandle.ab>
    14 #include <Classes/System/Drawing/Color.ab>
    15 #include <Classes/System/Drawing/Point.ab>
    16 #include <Classes/System/Drawing/Size.ab>
    17 #include <Classes/System/Drawing/Rectangle.ab>
     6#require <windows/WindowHandle.sbp>
     7#require <Classes/System/Windows/Forms/misc.ab>
     8#require <Classes/System/Windows/Forms/CreateParams.ab>
     9#require <Classes/System/Windows/Forms/Message.ab>
     10#require <Classes/System/Windows/Forms/PaintEventArgs.ab>
     11#require <Classes/System/misc.ab>
     12#require <Classes/System/Math.ab>
     13#require <Classes/System/Threading/WaitHandle.ab>
     14#require <Classes/System/Drawing/Color.ab>
     15#require <Classes/System/Drawing/Point.ab>
     16#require <Classes/System/Drawing/Size.ab>
     17#require <Classes/System/Drawing/Rectangle.ab>
     18#require <Classes/System/Runtime/InteropServices/GCHandle.ab>
     19
     20TypeDef InvokeProc = *Function(p As VoidPtr) As VoidPtr
    1821
    1922Class AsyncResultForInvoke
    … …  
    2528    End Sub
    2629
    27     Override Function AsyncState() As *IObject
    28         Return 0
    29     End Function
    30 
    31     Override Function AsyncWaitHandle() As *WaitHandle
    32         Return VarPtr(AsyncWaitHandle)
     30    Override Function AsyncState() As IObject
     31        Return Nothing
     32    End Function
     33
     34    Override Function AsyncWaitHandle() As WaitHandle
     35        Return waitHandle
    3336    End Function
    3437
    … …  
    3841
    3942    Override Function IsCompleted() As BOOL
    40         Return AsyncWaitHandle()->WaitOne(0, FALSE)
     43        Return waitHandle.WaitOne(0, FALSE)
    4144    End Function
    4245
    … …  
    5659Class AsyncInvokeData
    5760Public
    58     FuncPtr As *Function(p As VoidPtr) As VoidPtr
     61    FuncPtr As InvokeProc
    5962    Data As *VoidPtr
    60     AsyncResult As *AsyncResultForInvoke
     63    AsyncResult As AsyncResultForInvoke
    6164End Class
    6265
    6366Class Control
    64     Inherits IWin32Window
     67'   Inherits IWin32Window
    6568Public
    6669    '---------------------------------------------------------------------------
    6770    ' Public Properties
    6871
    69     Function AllowDrop() As BOOL
    70     End Function
    71 
    72     Override Function Handle() As HWND
     72    Function AllowDrop() As Boolean
     73    End Function
     74
     75    /*Override*/ Function Handle() As HWND
    7376        Return wnd.HWnd
    7477    End Function
    7578
    7679    ' IDropTargetを実装するのでDragAcceptFiles関数は呼ばない。
    77     Sub AllowDrop(a As BOOL)
    78     End Sub
    79 
    80     Const Function Visible() As BOOL
     80    Sub AllowDrop(a As Boolean)
     81    End Sub
     82
     83    Const Function Visible() As Boolean
    8184        Return wnd.Visible
    8285    End Function
    8386
    84     Sub Visible(v As BOOL)
     87    Sub Visible(v As Boolean)
    8588        wnd.Visible(v)
    8689    End Sub
    … …  
    9699    End Sub
    97100
    98     Const Function Enabled() As BOOL
     101    Const Function Enabled() As Boolean
    99102        Return wnd.Enabled
    100103    End Function
    101104
    102     Sub Enabled(e As BOOL)
     105    Sub Enabled(e As Boolean)
    103106        ' OnEnabledChangedはWM_ENABLE経由で呼ばれる
    104107        wnd.Enabled(e)
    … …  
    108111        Dim wr As RECT
    109112        wr = wnd.WindowRect
    110         Dim r As Rectangle(wr)
     113        Dim r = New Rectangle(wr)
    111114        Dim parent = Parent
    112         If parent <> 0 Then
     115        If Object.ReferenceEquals(parent, Nothing) Then
    113116            Return parent->RectangleToClient(r)
    114117        Else
    … …  
    117120    End Function
    118121
    119     Sub Bounds(ByRef r As Rectangle)
     122    Sub Bounds(r As Rectangle)
    120123        SetBoundsCore(r.X, r.Y, r.Width, r.Height, BoundsSpecified.All)
    121124    End Sub
    … …  
    138141
    139142    Const Function ClientRectangle() As Rectangle
    140         Dim r As Rectangle(wnd.ClientRect)
    141         Return r
     143        Return New Rectangle(wnd.ClientRect)
    142144    End Function
    143145
    … …  
    191193
    192194    Const Function PointToScreen(p As Point) As Point
    193         wnd.ClientToScreen(ByVal VarPtr(p) As *POINTAPI)
    194         Return r
     195        PointToScreen = New Point
     196        ret.X = p.X
     197        ret.Y = p.Y
     198        wnd.ClientToScreen(ByVal VarPtr(PointToScreen) As *POINTAPI)
    195199    End Function
    196200
    197201    Const Function PointToClient(p As Point) As Point
    198         wnd.ScreenToClient(ByVal VarPtr(p) As *POINTAPI)
    199         Return r
    200     End Function
    201 
    202     Const Function RectangleToScreen(p As Rectangle) As Rectangle
    203         wnd.ClientToScreen(ByVal VarPtr(p) As *POINTAPI)
    204         Return p
    205     End Function
    206 
    207     Const Function RectangleToClient(p As Rectangle) As Rectangle
    208         wnd.ScreenToClient(ByVal VarPtr(p) As *POINTAPI)
    209         Return p
    210     End Function
    211 
    212     Const Function InvokeRequired() As BOOL
     202        PointToScreen = New Point
     203        ret.X = p.X
     204        ret.Y = p.Y
     205        wnd.ScreenToClient(ByVal VarPtr(PointToScreen) As *POINTAPI)
     206    End Function
     207
     208    Const Function RectangleToScreen(r As Rectangle) As Rectangle
     209        Dim rc = r.ToRECT
     210        wnd.ClientToScreen(rc)
     211        Return New Rectangle(rc)
     212    End Function
     213
     214    Const Function RectangleToClient(r As Rectangle) As Rectangle
     215        Dim rc As RECT
     216        rc = r.ToRECT()
     217        wnd.ScreenToClient(rc)
     218        Return New Rectangle(rc)
     219    End Function
     220
     221    Const Function InvokeRequired() As Boolean
    213222        Return wnd.ThreadID <> GetCurrentThreadId()
    214223    End Function
    … …  
    224233    End Sub
    225234
    226     Function Parent() As *Control
     235    Function Parent() As Control
    227236        Return parent
     237    End Function
     238
     239    Const Function IsHandleCreated() As Boolean
     240        Return wnd.HWnd <> 0
    228241    End Function
    229242
    … …  
    240253    End Sub
    241254
    242     Sub Control(ByRef text As String)
     255    Sub Control(text As String)
    243256        Dim sz = DefaultSize()
    244257        Control(text, 100, 100, sz.Width, sz.Height)
    245258    End Sub
    246259
    247     Sub Control(ByRef parent As Control, ByRef text As String)
     260    Sub Control(parent As Control, text As String)
    248261        Dim sz = DefaultSize()
    249262        Control(parent, text, 100, 100, sz.Width, sz.Height)
    250263    End Sub
    251264
    252     Sub Control(ByRef text As String, left As Long, top As Long, width As Long, height As Long)
     265    Sub Control(text As String, left As Long, top As Long, width As Long, height As Long)
    253266        This.text = text
    254267        bkColor = DefaultBackColor
    … …  
    257270    End Sub
    258271
    259     Sub Control(ByRef parent As Control, ByRef text As String, left As Long, top As Long, width As Long, height As Long)
     272    Sub Control(parent As Control, text As String, left As Long, top As Long, width As Long, height As Long)
    260273        This.parent = VarPtr(parent)
    261274        Control(text, left, top, width, height)
    … …  
    276289    ' 同期関数呼出、Controlが作成されたスレッドで関数を実行する。
    277290    ' 関数は同期的に呼び出されるので、関数が終わるまでInvokeは制御を戻さない。
    278     Function Invoke(pfn As *Function(p As VoidPtr) As VoidPtr, p As VoidPtr) As VoidPtr
     291    Function Invoke(pfn As InvokeProc, p As VoidPtr) As VoidPtr
    279292        Return wnd.SendMessage(WM_CONTROL_INVOKE, p As WPARAM, pfn As LPARAM) As VoidPtr
    280293    End Function
    … …  
    283296    ' 関数は非同期的に呼び出されるので、BeginInvokeはすぐに制御を戻す。
    284297    ' 後にEndInvokeを呼び出すことにより、関数の戻り値を受け取れる。
    285     ' 注意：現状の実装では必ずEndInvokeを呼び出す必要がある。
    286     Function BeginInvoke(pfn As *Function(p As VoidPtr) As VoidPtr, p As VoidPtr) As *IAsyncResult
     298    Function BeginInvoke(pfn As InvokeProc, p As VoidPtr) As IAsyncResult
    287299        ' EndInvokeがDeleteする
    288         Dim pAsyncResult = New AsyncResultForInvoke(CreateEvent(0, FALSE, FALSE, 0))
     300        Dim asyncResult = New AsyncResultForInvoke(CreateEvent(0, FALSE, FALSE, 0))
    289301        ' OnControlBeginInvokeがDeleteする
    290         Dim pAsyncInvokeData = New AsyncInvokeData
    291         With pAsyncInvokeData[0]
     302        Dim asyncInvokeData = New AsyncInvokeData
     303        With asyncInvokeData
    292304            .FuncPtr = pfn
    293305            .Data = p
    294             .AsyncResult = pAsyncResult
     306            .AsyncResult = asyncResult
    295307        End With
    296         wnd.PostMessage(WM_CONTROL_BEGININVOKE, 0, pAsyncInvokeData As LPARAM)
     308        Dim gch = GCHandle.Alloc(asyncInvokeData)
     309        wnd.PostMessage(WM_CONTROL_BEGININVOKE, 0, GCHandle.ToIntPtr(gch))
    297310        Return pAsyncResult
    298311    End Function
    … …  
    300313    ' BeginInvokeで呼び出した関数の戻り値を受け取る。
    301314    ' その関数がまだ終了していない場合、終了するまで待機する。
    302     Function EndInvoke(ar As *IAsyncResult) As VoidPtr
    303         ar->WaitHandle->WaitOne()
    304         Dim arInvoke = ar As *AsyncResultForInvoke
    305         Dim result = arInvoke->Result
    306         Delete arInvoke
    307         Return result
     315    Function EndInvoke(ar As IAsyncResult) As VoidPtr
     316        ar.WaitHandle.WaitOne()
     317        Dim arInvoke = ar As AsyncResultForInvoke
     318        Return arInvoke.Result
    308319    End Function
    309320
    310321    ' 与えられたウィンドウハンドルがControl（若しくはその派生クラス）の
    311322    ' インスタンスに対応するものであった場合、
    312     ' 元のインスタンスへのポインタを返す。
    313     ' そうでなければヌルポインタを返す。
    314     Static Function FromHandle(hwnd As HWND) As *Control
     323    ' 元のインスタンスを返す。
     324    ' そうでなければNothingを返す。
     325    Static Function FromHandle(hwnd As HWND) As Control
    315326        If IsWindow(hwnd) Then
    316             Dim className[19] As Byte 'Len (WindowClassName)
    317             GetClassName(hwnd, className, Len (className))
    318             If memcmp(className, WindowClassName, Len (WindowClassName)) = 0 Then
    319                 Return GetWindowLongPtr(hwnd, GWLP_THIS) As *Control
     327            If GetClassLongPtr(hwnd, GCW_ATOM) = atom Then
     328                Dim gch = GCHandle.FromIntPtr(GetWindowLongPtr(hwnd, GWLP_THIS))
     329                Return gch.Target As Control
    320330            End If
    321331        End If
    322         Return 0 As *Control
     332        Return Nothing As Control
    323333    End Function
    324334
    … …  
    327337    End Sub
    328338
    329     /*Override*/ Virtual Function ToString() As String
     339    Override Function ToString() As String
    330340        Return text
    331341    End Function
    … …  
    351361    '---------------------------------------------------------------------------
    352362    ' Protected Properties
    353 '   Const Virtual Function CanRaiseEvents() As BOOL
    354     Virtual Function CreateParams() As *CreateParams
    355         Return VarPtr(createParams)
     363'   Const Virtual Function CanRaiseEvents() As Boolean
     364    Virtual Function CreateParams() As CreateParams
     365        Return createParams
    356366    End Function
    357367
    … …  
    373383    Virtual Sub CreateHandle()
    374384        Dim createParams = CreateParams()
    375         TlsSetValue(tlsIndex, VarPtr(This))
     385        Dim gch = GCHandle.Alloc(This)
     386        TlsSetValue(tlsIndex, GCHandle.ToIntPtr(gch) As VoidPtr)
    376387        With createParams[0]
    377388            Dim hwndParent = 0 As HWND
    378             If parent <> 0 Then
    379                 hwndParent = parent->Handle
     389            If Not Object.ReferenceEquals(parent, Nothing) Then
     390                hwndParent = parent.Handle
    380391            End If
    381392            If CreateWindowEx(.ExStyle, atom As ULONG_PTR As PCSTR, text, .Style, _
    … …  
    383394                hwndParent, 0, hInstance, 0) = 0 Then
    384395                ' Error
    385                 Dim buf[1023] As Byte
    386                 wsprintf(buf, Ex"Control: CreateWindowEx failed. Error code: &h%08X\r\n", GetLastError())
     396                Dim buf[1023] As TCHAR
     397                wsprintf(buf, ToTCStr(Ex"Control: CreateWindowEx failed. Error code: &h%08X\r\n"), GetLastError())
    387398                OutputDebugString(buf)
    388399'               Debug
    … …  
    390401            End If
    391402        End With
    392     End Sub
    393 
    394     Virtual Sub DefWndProc(ByRef m As Message)
     403        gch.Free()
     404    End Sub
     405
     406    Virtual Sub DefWndProc(m As Message)
    395407        m.Result = DefWindowProc(m.HWnd, m.Msg, m.WParam, m.LParam)
    396408    End Sub
    397409
    398     Virtual Sub WndProc(ByRef m As Message)
     410    Virtual Sub WndProc(m As Message)
    399411        With m
    400412            Select Case .Msg
    … …  
    402414                    .Result = text.Length
    403415                Case WM_GETTEXT
    404                     Dim size = Math.Min(.WParam As ULONG_PTR, text.Length As ULONG_PTR + 1)
    405                     memcpy(.LParam As *Byte, text.StrPtr, size)
     416                    Dim size = Math.Min(.WParam As ULONG_PTR, (text.Length + 1) As ULONG_PTR)
     417                    memcpy(.LParam As PCTSTR, ToTCStr(text), size * SizeOf (TCHAR))
    406418                    .Result = size
    407419                Case WM_SETTEXT
    408                     text = .LParam As *Byte
     420                    text = New String(.LParam As PCTSTR)
    409421                Case WM_ENABLE
    410                     Dim e As EventArgs
    411                     OnEnabledChanged(e)
     422                    OnEnabledChanged(EventArgs.Empty)
    412423                Case WM_ERASEBKGND
    413424                    ' OnPaintBackgroundに移すべき
    … …  
    420431                    DeleteObject(hbr)
    421432                Case WM_CONTROL_INVOKE
    422                     Dim pfn As *Function(p As VoidPtr) As VoidPtr
    423                     pfn = .LParam As *Function(p As VoidPtr) As VoidPtr
     433                    Dim pfn = .LParam As InvokeProc
    424434                    .Result = pfn(m.WParam As VoidPtr) As LRESULT
    425435                Case WM_CONTROL_BEGININVOKE
    426436                    OnControlBeginInvoke(m)
     437                Case WM_CREATE
     438                    OnHandleCreated(EventArgs.Empty)
    427439                Case Else
    428440                    DefWndProc(m)
    … …  
    450462
    451463    Virtual Sub SetBoundsCore(x As Long, y As Long, width As Long, height As Long, bs As BoundsSpecified)
    452         If Not (bs As DWord And BoundsSpecified.X As DWord) Then
     464'       If Not (bs As DWord And BoundsSpecified.X As DWord) Then
    453465            x = Left
    454         End If
    455         If Not (bs As DWord And BoundsSpecified.Y As DWord) Then
     466'       End If
     467'       If Not (bs As DWord And BoundsSpecified.Y As DWord) Then
    456468            y = Right
    457         End If
    458         If Not (bs As DWord And BoundsSpecified.Width As DWord) Then
     469'       End If
     470'       If Not (bs As DWord And BoundsSpecified.Width As DWord) Then
    459471            width = Width
    460         End If
    461         If Not (bs As DWord And BoundsSpecified.Height As DWord) Then
     472'       End If
     473'       If Not (bs As DWord And BoundsSpecified.Height As DWord) Then
    462474            height = Height
    463         End If
     475'       End If
    464476        wnd.Move(x, y, width, height)
    465477    End Sub
    … …  
    471483    End Sub
    472484
    473     Virtual Sub OnPaintBackground(ByRef e As PaintEventArgs) : End Sub
    474     Virtual Sub OnEnabledChanged(ByRef e As EventArgs) : End Sub
    475     Virtual Sub OnBackColorChanged(ByRef e As EventArgs) : End Sub
    476     Virtual Sub OnTextChanged(ByRef e As EventArgs)
    477         wnd.SetText(text.StrPtr)
     485    Virtual Sub OnPaintBackground(e As PaintEventArgs) : End Sub
     486    Virtual Sub OnEnabledChanged(e As EventArgs) : End Sub
     487    Virtual Sub OnBackColorChanged(e As EventArgs) : End Sub
     488    Virtual Sub OnHandleCreated(e As EventArgs) : End Sub
     489    Virtual Sub OnTextChanged(e As EventArgs)
     490        wnd.SetText(ToTCStr(text))
    478491    End Sub
    479492
    … …  
    482495    wnd As WindowHandle
    483496    text As String
    484     parent As *Control
     497    parent As Control
    485498    bkColor As Color
    486499
    … …  
    496509    Static Const WM_CONTROL_BEGININVOKE = WM_USER + 1 As DWord
    497510
    498     Static Const WindowClassName = "ActiveBasic Control" As *Byte
     511    Static Const WindowClassName = "ActiveBasic Control"
    499512Public
    500513    Static Sub Initialize(hinst As HINSTANCE)
    … …  
    519532        atom = RegisterClassEx(wcx)
    520533        If atom = 0 Then
    521             Dim buf[1023] As Byte
    522             wsprintf(buf, Ex"Control: RegisterClasseEx failed. Error code: &h%08X\r\n", GetLastError())
     534            Dim buf[1023] As TCHAR
     535            wsprintf(buf, ToTCStr(Ex"Control: RegisterClasseEx failed. Error code: &h%08X\r\n"), GetLastError())
    523536            OutputDebugString(buf)
    524537            Debug
    … …  
    543556    ' Windowsから呼ばれるウィンドウプロシージャ。WndProc
    544557    Static Function WndProcFirst(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
    545         Dim pThis = Control.FromHandle(hwnd) As *Control
    546         If pThis = 0 Then
    547             pThis = TlsGetValue(tlsIndex)
     558        Dim rThis = Control.FromHandle(hwnd) As Control
     559        If Object.ReferenceEquals(rThis As Object, Nothing) Then
     560            Dim gchValue = TlsGetValue(tlsIndex) As LONG_PTR
     561            Dim gch = GCHandle.FromIntPtr(gchValue)
     562            rThis = gch.Target As Control
    548563            ' ウィンドウが作られて最初にWndProcFirstが呼ばれたとき
    549             TlsSetValue(tlsIndex, 0)
    550             If pThis = 0 Then
     564            If Object.ReferenceEquals(rThis, Nothing) Then
    551565                ' あってはならない事態
    552566                Debug
    … …  
    554568            End If
    555569'           Debug
    556             pThis->wnd = hwnd
    557             SetWindowLongPtr(hwnd, GWLP_THIS, pThis As LONG_PTR)
     570            rThis.wnd = New WindowHandle(hwnd)
     571            SetWindowLongPtr(hwnd, GWLP_THIS, gchValue)
    558572        End If
    559573        Dim m As Message
    560574        m = Message.Create(hwnd, msg, wp, lp)
    561         pThis->WndProc(m)
     575        rThis.WndProc(m)
    562576        Return m.Result
    563577    End Function
    564578
    565579    ' BeginInvokeが呼ばれたときの処理
    566     Sub OnControlBeginInvoke(ByRef m As Message)
    567         Dim data As *AsyncInvokeData
    568         data = m.LParam As *AsyncInvokeData
    569         Dim asyncResult As *AsyncResultForInvoke
    570         asyncResult->Result = data->FuncPtr(data->Data)
    571         Dim wh = asyncResult->AsyncWaitHandle
    572         SetEvent(wh->Handle)
    573         Delete data
     580    Sub OnControlBeginInvoke(m As Message)
     581        Dim gch = GCHandle.FromIntPtr(m.LParam)
     582        Dim data = gch.Target As AsyncInvokeData
     583        With data
     584            Dim pfn = .FuncPtr
     585            .AsyncResult.Result = pfn(.Data)
     586            SetEvent(.AsyncResult.AsyncWaitHandle.Handle)
     587        End With
    574588    End Sub
    575589End Class
Note: See TracChangeset for help on using the changeset viewer.