Ignore:
Timestamp:
Jun 29, 2009, 4:03:45 AM (15 years ago)
Author:
イグトランス (egtra)
Message:

最新のコンパイラに通るように修正。参照クラスのセマンティクスに合うように修正(Setter系プロパティの削除など)。

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ab5.0/ablib/src/com/vbobject.ab

    r497 r709  
    66Namespace COM
    77
    8 Class VBObject
     8Class VBObjectBase
     9    Implements System.IDisposable, System.IEquatable<VBObjectBase>
    910Public
    10     Sub VBObject()
    11         pdisp = 0
    12     End Sub
    13 
    14     Sub VBObject(className As String, pOuter As *IUnknown, clsContext As DWord)
    15         VBObject(ToWCStr(className), pOuter, clsContext)
    16     End Sub
    17 
    18     Sub VBObject(className As PCSTR, pOuter As *IUnknown, clsContext As DWord)
    19         VBObject(ToWCStr(className), pOuter, clsContext)
    20     End Sub
    21 
    22     Sub VBObject(className As PCWSTR, pOuter As *IUnknown, clsContext As DWord)
    23         pdisp = 0
    24         Dim clsid As CLSID
    25         Dim hr = _System_CLSIDFromString(className, clsid)
    26         VBObject(clsid, pOuter, clsContext)
    27     End Sub
    28 
    29     Sub VBObject(ByRef clsid As CLSID, pOuter As *IUnknown, clsContext As DWord)
    30         Dim hr = CoCreateInstance(clsid, pOuter, clsContext, IID_IDispatch, pdisp)
    31     End Sub
    32 
    33     Sub VBObject(ByRef obj As VBObject)
    34         pdisp = obj.pdisp
    35         pdisp->AddRef()
    36     End Sub
    37 
    38     Sub ~VBObject()
    39         Clear()
     11    Sub VBObjectBase()
     12        disp = Nothing
     13    End Sub
     14
     15    Sub VBObjectBase(dispObj As IDispatch)
     16        copy(disp, dispObj)
     17    End Sub
     18
     19    Sub ~VBObjectBase()
     20        Dispose()
    4021    End Sub
    4122
    4223    Sub Clear()
    43         If pdisp <> 0 Then
    44             pdisp->Release()
    45             pdisp = 0
     24        Dispose()
     25    End Sub
     26
     27    Virtual Sub Dispose()
     28        If ObjPtr(disp) <> 0 Then
     29            disp.Release()
     30            disp = Nothing
    4631        End If
    4732    End Sub
    4833
    49     Function Operator [](name As PCWSTR) As DispatchCaller
    50         Return GetCaller(name)
    51     End Function
    52 
    53     Function Operator [](name As String) As DispatchCaller
    54         Return GetCaller(ToWCStr(name))
    55     End Function
    56 
    57     Function Equals(y As VBObject) As Boolean
    58         Return _System_COMReferenceEquals(pdisp, y.pdisp)
     34'   Override Function Equals(y As Object) As Boolean
     35'   End Function
     36
     37    Virtual Function Equals(y As VBObjectBase) As Boolean
     38        Return Detail.COMReferenceEquals(This.Dispatch, y.Dispatch)
    5939    End Function
    6040/*
    … …  
    6545    End Function
    6646*/
    67     Function Operator ==(y As VBObject) As Boolean
    68         Return Equals(y)
    69     End Function
    70 
    71     Function Operator <>(y As VBObject) As Boolean
    72         Return Not Equals(y)
    73     End Function
    74 
    75     Sub Assign(p As *IDispatch)
     47
     48    Function Copy() As IDispatch
     49        copy(Copy, disp)
     50    End Function
     51
     52    Sub Attach(ByRef y As IDispatch)
     53'       Clear()
     54'       move(pdisp, y)
     55    End Sub
     56
     57    Function Detach() As IDispatch
     58        move(Detach, disp)
     59    End Function
     60
     61    Function Dispatch() As IDispatch
     62        Dispatch = disp
     63    End Function
     64Protected
     65
     66    Sub attach(ByRef y As IDispatch)
    7667        Clear()
    77         VBObject.Copy(pdisp, p)
    78     End Sub
    79 
    80     Function Copy() As *IDispatch
    81         VBObject.Copy(GetDispatch, pdisp)
    82     End Function
    83 
    84     Sub Attach(ByRef p As *IDispatch)
    85         Clear()
    86         VBObject.Move(pdisp, p)
    87     End Sub
    88 
    89     Function Detach() As *IDispatch
    90         VBObject.Move(Detach, pdisp)
    91     End Function
    92 
    93     Function Dispatch() As *IDispatch
    94         Dispatch = pdisp
    95     End Function
     68        move(disp, y)
     69    End Sub
     70
     71Private
     72    disp As IDispatch
     73
     74    Static Sub copy(ByRef dst As IDispatch, ByVal src As IDispatch)
     75        dst = src
     76        If ObjPtr(src) <> 0 Then
     77            src.AddRef()
     78        End If
     79    End Sub
     80
     81    Static Sub move(ByRef dst As IDispatch, ByRef src As IDispatch)
     82        dst = src
     83        src = Nothing
     84    End Sub
     85
     86End Class
     87
     88Class VBObject
     89    Inherits VBObjectBase
     90Public
     91    Static Function Attach(y As IDispatch) As VBObject
     92        Attach = New VBObject
     93        Attach.attach(y)
     94    End Function
     95
     96    Sub VBObject()
     97        disp = Nothing
     98    End Sub
     99
     100    Sub VBObject(className As String, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord)
     101        VBObjectBase(createInstance(className, outer, clsContext))
     102    End Sub
     103
     104    Sub VBObject(ByRef clsid As CLSID, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord)
     105        VBObjectBase(createInstance(clsid, outer, clsContext))
     106    End Sub
     107Private
     108    Function createInstance(className As String, outer As IUnknown, clsContext As DWord) As IDispatch
     109        Dim clsid = Detail.StringToCLSID(ToWCStr(className))
     110        createInstance = createInstance(clsid, outer, clsContext)
     111    End Function
     112
     113    Function createInstance(ByRef clsid As CLSID, outer As IUnknown, clsContext As DWord) As IDispatch
     114        Dim hr = CoCreateInstance(clsid, ObjPtr(outer), clsContext, IID_IDispatch, createInstance)
     115        Windows.ThrowIfFailed(hr)
     116    End Function
     117Public
     118
     119    Function Operator [](name As PCWSTR) As DispatchCaller
     120        Return GetCaller(name)
     121    End Function
     122
     123    Function Operator [](name As String) As DispatchCaller
     124        Return GetCaller(ToWCStr(name))
     125    End Function
     126
    96127Private
    97128    Function GetCaller(name As PCWSTR) As DispatchCaller
    98129        Dim dispid As DISPID
    99         Dim hr = pdisp->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
    100         Return New DispatchCaller(pdisp, dispid)
    101     End Function
    102 
    103     pdisp As *IDispatch
    104 
    105     Static Sub Copy(ByRef dst As *IDispatch, ByVal src As *IDispatch)
    106         dst = src
    107         dst->AddRef()
    108     End Sub
    109 
    110     Static Sub Move(ByRef dst As *IDispatch, ByRef src As *IDispatch)
    111         dst = src
    112         src = 0
    113     End Sub
     130        Dim hr = Dispatch.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
     131        Windows.ThrowIfFailed(hr)
     132        Return New DispatchCaller(disp, dispid)
     133    End Function
    114134End Class
    115135
    116136Class DispatchCaller
     137    Implements System.IDisposable
    117138Public
    118139    Sub DispatchCaller()
    119140    End Sub
    120     Sub DispatchCaller(pDispatch As *IDispatch, dispatchId As DISPID)
    121         pdisp = pDispatch
    122         pdisp->AddRef()
     141    Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID)
     142        disp = dispObj
     143        disp.AddRef()
    123144        dispid = dispatchId
    124145    End Sub
    125146
    126     Sub DispatchCaller(ByRef dc As DispatchCaller)
    127         pdisp = dc.pdisp
    128         pdisp->AddRef()
    129         dispid = dc.dispid
    130     End Sub
    131 
    132     Sub Operator =(ByRef dc As DispatchCaller)
    133         Dispose()
    134         DispatchCaller(dc)
    135     End Sub
    136 
    137147    Sub Dispose()
    138         If pdisp <> 0 Then
    139             pdisp->Release()
    140             pdisp = 0
     148        If ObjPtr(disp) <> NULL Then
     149            disp.Release()
     150            disp = Nothing
    141151        End If
    142152    End Sub
    … …  
    154164            .cNamedArgs = 0
    155165        End With
    156         Dim ret As VARIANT
    157         Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ret, 0, 0)
    158         Dispose()
    159         Prop = New Variant
    160         v.Attach(ret)
    161         Return v
     166        Call = New Variant
     167        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0)
     168        Windows.ThrowIfFailed(hr)
     169        Dispose()
    162170    End Function
    163171
    … …  
    186194            .cNamedArgs = 0
    187195        End With
    188         Dim ret As VARIANT
    189         Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
    190         Dispose()
    191         Dim v = New Variant
    192         v.Attach(ret)
    193         Return v
     196        Call = New Variant
     197        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0)
     198        Windows.ThrowIfFailed(hr)
     199        Dispose()
    194200    End Function
    195201
    … …  
    259265            .cNamedArgs = 1
    260266        End With
    261         Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
    262         Dispose()
    263     End Sub
    264 
    265 
    266     pdisp As *IDispatch
     267        Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
     268        Windows.ThrowIfFailed(hr)
     269        Dispose()
     270    End Sub
     271
     272    disp As IDispatch
    267273    dispid As DISPID
    268274End Class
    … …  
    276282End Function
    277283
    278 Function CallByName(obj As *IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
     284Function CallByName(obj As IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
    279285    Dim dispid As DISPID
    280     Dim hr = obj->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
     286    Dim hr = obj.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
     287    Windows.ThrowIfFailed(hr)
    281288    Dim dispParams As DISPPARAMS
    282289    With dispParams
    … …  
    286293        .cNamedArgs = 0
    287294    End With
    288     Dim ret As VARIANT
    289     hr = obj->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
    290295    CallByName = New Variant
    291     CallByName.Attach(ret)
    292     Return CallByName
     296    hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0)
     297    Windows.ThrowIfFailed(hr)
    293298End Function
    294299/*
    … …  
    300305    Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
    301306End Function
    302 /*
     307*/
    303308#ifdef _WIN32_DCOM
    304309Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
    … …  
    306311    Dim si As COSERVERINFO
    307312    Dim context As DWord
    308     If /*Server = 0 OrElse* / Server[0] = 0 Then
     313    If /*Server = 0 OrElse*/ Server[0] = 0 Then
    309314        context = CLSCTX_SERVER
    310315    Else
    … …  
    332337End Function
    333338#endif
    334 */
    335 Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT
     339
     340
     341Namespace Detail
     342Function StringToCLSID(pwString As PCWSTR) As CLSID
    336343    If pwString[0] = &h007b As WCHAR Then
    337344        ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
    338         _System_CLSIDFromString = CLSIDFromString(pwString, guid)
     345        Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID))
    339346    Else
    340         _System_CLSIDFromString = CLSIDFromProgID(pwString, guid)
    341     End If
    342 End Function
    343 
    344 Function _System_COMReferenceEquals(p As *IUnknown, q As *IUnknown) As Boolean
    345     If p = q Then
     347        Windows.ThrowIfFailed(CLSIDFromProgID(pwString, StringToCLSID))
     348    End If
     349End Function
     350
     351Function COMReferenceEquals(p As IUnknown, q As IUnknown) As Boolean
     352    If ObjPtr(p) = ObjPtr(q) Then
    346353        Return True
    347     Else If p = 0 Or q = 0 Then
     354    Else If ObjPtr(p) = 0 Or ObjPtr(q) = 0 Then
    348355        Return False
    349356    End If
    350357
    351     Dim punkX = _System_GetUnknown(p)
    352     Dim punkY = _System_GetUnknown(q)
    353     If punkX = punkY Then
    354         _System_COMReferenceEquals = True
     358    Dim punkX = GetUnknown(p)
     359    Dim punkY = GetUnknown(q)
     360    If ObjPtr(punkX) = ObjPtr(punkY) Then
     361        COMReferenceEquals = True
    355362    Else
    356         _System_COMReferenceEquals = False
    357     End If
    358     punkX->Release()
    359     punkY->Release()
    360 End Function
    361 
    362 Function _System_GetUnknown(p As *IUnknown) As *IUnknown 'pは任意のCOMインタフェース
    363     If FAILDED(pdisp->QueryInterface(IID_Unknown, _System_GetUnknown)) Then
    364         GetUnknown = 0
    365     End If
    366 End Function
     363        COMReferenceEquals = False
     364    End If
     365    punkX.Release()
     366    punkY.Release()
     367End Function
     368
     369Function GetUnknown(p As IUnknown) As IUnknown 'pは任意のCOMインタフェース
     370    If FAILED(p.QueryInterface(IID_IUnknown, GetUnknown)) Then
     371        GetUnknown = Nothing
     372    End If
     373End Function
     374End Namespace 'Detail
    367375
    368376End Namespace 'COM
Note: See TracChangeset for help on using the changeset viewer.