Changeset 709 for trunk/ab5.0/ablib/src/com/vbobject.ab
- Timestamp:
- Jun 29, 2009, 4:03:45 AM (16 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/ab5.0/ablib/src/com/vbobject.ab
r497 r709 6 6 Namespace COM 7 7 8 Class VBObject 8 Class VBObjectBase 9 Implements System.IDisposable, System.IEquatable<VBObjectBase> 9 10 Public 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() 40 21 End Sub 41 22 42 23 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 46 31 End If 47 32 End Sub 48 33 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) 59 39 End Function 60 40 /* … … 65 45 End Function 66 46 */ 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 64 Protected 65 66 Sub attach(ByRef y As IDispatch) 76 67 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 71 Private 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 86 End Class 87 88 Class VBObject 89 Inherits VBObjectBase 90 Public 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 107 Private 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 117 Public 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 96 127 Private 97 128 Function GetCaller(name As PCWSTR) As DispatchCaller 98 129 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 114 134 End Class 115 135 116 136 Class DispatchCaller 137 Implements System.IDisposable 117 138 Public 118 139 Sub DispatchCaller() 119 140 End Sub 120 Sub DispatchCaller( pDispatch As *IDispatch, dispatchId As DISPID)121 pdisp = pDispatch122 pdisp->AddRef()141 Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID) 142 disp = dispObj 143 disp.AddRef() 123 144 dispid = dispatchId 124 145 End Sub 125 146 126 Sub DispatchCaller(ByRef dc As DispatchCaller)127 pdisp = dc.pdisp128 pdisp->AddRef()129 dispid = dc.dispid130 End Sub131 132 Sub Operator =(ByRef dc As DispatchCaller)133 Dispose()134 DispatchCaller(dc)135 End Sub136 137 147 Sub Dispose() 138 If pdisp <> 0Then139 pdisp->Release()140 pdisp = 0148 If ObjPtr(disp) <> NULL Then 149 disp.Release() 150 disp = Nothing 141 151 End If 142 152 End Sub … … 154 164 .cNamedArgs = 0 155 165 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() 162 170 End Function 163 171 … … 186 194 .cNamedArgs = 0 187 195 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() 194 200 End Function 195 201 … … 259 265 .cNamedArgs = 1 260 266 End With 261 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)262 Dispose()263 End Sub264 265 266 pdisp As *IDispatch267 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 267 273 dispid As DISPID 268 274 End Class … … 276 282 End Function 277 283 278 Function CallByName(obj As *IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant284 Function CallByName(obj As IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant 279 285 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) 281 288 Dim dispParams As DISPPARAMS 282 289 With dispParams … … 286 293 .cNamedArgs = 0 287 294 End With 288 Dim ret As VARIANT289 hr = obj->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)290 295 CallByName = New Variant 291 CallByName.Attach(ret)292 Return CallByName296 hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0) 297 Windows.ThrowIfFailed(hr) 293 298 End Function 294 299 /* … … 300 305 Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL) 301 306 End Function 302 /* 307 */ 303 308 #ifdef _WIN32_DCOM 304 309 Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject … … 306 311 Dim si As COSERVERINFO 307 312 Dim context As DWord 308 If /*Server = 0 OrElse* 313 If /*Server = 0 OrElse*/ Server[0] = 0 Then 309 314 context = CLSCTX_SERVER 310 315 Else … … 332 337 End Function 333 338 #endif 334 */ 335 Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT 339 340 341 Namespace Detail 342 Function StringToCLSID(pwString As PCWSTR) As CLSID 336 343 If pwString[0] = &h007b As WCHAR Then 337 344 ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。 338 _System_CLSIDFromString = CLSIDFromString(pwString, guid)345 Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID)) 339 346 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 Boolean345 If p = qThen347 Windows.ThrowIfFailed(CLSIDFromProgID(pwString, StringToCLSID)) 348 End If 349 End Function 350 351 Function COMReferenceEquals(p As IUnknown, q As IUnknown) As Boolean 352 If ObjPtr(p) = ObjPtr(q) Then 346 353 Return True 347 Else If p = 0 Or q= 0 Then354 Else If ObjPtr(p) = 0 Or ObjPtr(q) = 0 Then 348 355 Return False 349 356 End If 350 357 351 Dim punkX = _System_GetUnknown(p)352 Dim punkY = _System_GetUnknown(q)353 If punkX = punkYThen354 _System_COMReferenceEquals = True358 Dim punkX = GetUnknown(p) 359 Dim punkY = GetUnknown(q) 360 If ObjPtr(punkX) = ObjPtr(punkY) Then 361 COMReferenceEquals = True 355 362 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() 367 End Function 368 369 Function GetUnknown(p As IUnknown) As IUnknown 'pは任意のCOMインタフェース 370 If FAILED(p.QueryInterface(IID_IUnknown, GetUnknown)) Then 371 GetUnknown = Nothing 372 End If 373 End Function 374 End Namespace 'Detail 367 375 368 376 End Namespace 'COM
Note:
See TracChangeset
for help on using the changeset viewer.