[175] | 1 | ' com/vbobject.ab
|
---|
| 2 |
|
---|
[497] | 3 | #require <com/variant.ab>
|
---|
[175] | 4 |
|
---|
[267] | 5 | Namespace ActiveBasic
|
---|
| 6 | Namespace COM
|
---|
| 7 |
|
---|
[709] | 8 | Class VBObjectBase
|
---|
| 9 | Implements System.IDisposable, System.IEquatable<VBObjectBase>
|
---|
[175] | 10 | Public
|
---|
[709] | 11 | Sub VBObjectBase()
|
---|
| 12 | disp = Nothing
|
---|
[175] | 13 | End Sub
|
---|
| 14 |
|
---|
[709] | 15 | Sub VBObjectBase(dispObj As IDispatch)
|
---|
| 16 | copy(disp, dispObj)
|
---|
[175] | 17 | End Sub
|
---|
| 18 |
|
---|
[709] | 19 | Sub ~VBObjectBase()
|
---|
| 20 | Dispose()
|
---|
[192] | 21 | End Sub
|
---|
| 22 |
|
---|
[709] | 23 | Sub Clear()
|
---|
| 24 | Dispose()
|
---|
[175] | 25 | End Sub
|
---|
| 26 |
|
---|
[709] | 27 | Virtual Sub Dispose()
|
---|
| 28 | If ObjPtr(disp) <> 0 Then
|
---|
| 29 | disp.Release()
|
---|
| 30 | disp = Nothing
|
---|
[175] | 31 | End If
|
---|
| 32 | End Sub
|
---|
| 33 |
|
---|
[709] | 34 | ' Override Function Equals(y As Object) As Boolean
|
---|
| 35 | ' End Function
|
---|
[175] | 36 |
|
---|
[709] | 37 | Virtual Function Equals(y As VBObjectBase) As Boolean
|
---|
| 38 | Return Detail.COMReferenceEquals(This.Dispatch, y.Dispatch)
|
---|
[175] | 39 | End Function
|
---|
| 40 | /*
|
---|
| 41 | Override Function GetHashCode() As Long
|
---|
[192] | 42 | Dim punk = _System_GetUnknown(pdisp)
|
---|
[175] | 43 | GetHashCode = _System_HashFromPtr(punk)
|
---|
| 44 | punk->Release()
|
---|
| 45 | End Function
|
---|
| 46 | */
|
---|
[709] | 47 |
|
---|
| 48 | Function Copy() As IDispatch
|
---|
| 49 | copy(Copy, disp)
|
---|
[175] | 50 | End Function
|
---|
| 51 |
|
---|
[709] | 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)
|
---|
[175] | 59 | End Function
|
---|
| 60 |
|
---|
[709] | 61 | Function Dispatch() As IDispatch
|
---|
| 62 | Dispatch = disp
|
---|
| 63 | End Function
|
---|
| 64 | Protected
|
---|
| 65 |
|
---|
| 66 | Sub attach(ByRef y As IDispatch)
|
---|
[175] | 67 | Clear()
|
---|
[709] | 68 | move(disp, y)
|
---|
[175] | 69 | End Sub
|
---|
| 70 |
|
---|
[709] | 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)
|
---|
[175] | 94 | End Function
|
---|
| 95 |
|
---|
[709] | 96 | Sub VBObject()
|
---|
| 97 | disp = Nothing
|
---|
[175] | 98 | End Sub
|
---|
| 99 |
|
---|
[709] | 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)
|
---|
[192] | 111 | End Function
|
---|
| 112 |
|
---|
[709] | 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)
|
---|
[192] | 116 | End Function
|
---|
[709] | 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 |
|
---|
[175] | 127 | Private
|
---|
| 128 | Function GetCaller(name As PCWSTR) As DispatchCaller
|
---|
| 129 | Dim dispid As DISPID
|
---|
[709] | 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)
|
---|
[175] | 133 | End Function
|
---|
| 134 | End Class
|
---|
| 135 |
|
---|
| 136 | Class DispatchCaller
|
---|
[709] | 137 | Implements System.IDisposable
|
---|
[175] | 138 | Public
|
---|
| 139 | Sub DispatchCaller()
|
---|
| 140 | End Sub
|
---|
[709] | 141 | Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID)
|
---|
| 142 | disp = dispObj
|
---|
| 143 | disp.AddRef()
|
---|
[175] | 144 | dispid = dispatchId
|
---|
| 145 | End Sub
|
---|
| 146 |
|
---|
| 147 | Sub Dispose()
|
---|
[709] | 148 | If ObjPtr(disp) <> NULL Then
|
---|
| 149 | disp.Release()
|
---|
| 150 | disp = Nothing
|
---|
[175] | 151 | End If
|
---|
| 152 | End Sub
|
---|
| 153 |
|
---|
| 154 | Sub ~DispatchCaller()
|
---|
| 155 | Dispose()
|
---|
| 156 | End Sub
|
---|
| 157 |
|
---|
| 158 | Function Prop() As Variant
|
---|
| 159 | Dim dispParams As DISPPARAMS
|
---|
| 160 | With dispParams
|
---|
| 161 | .rgvarg = 0
|
---|
| 162 | .rgdispidNamedArgs = 0
|
---|
| 163 | .cArgs = 0
|
---|
| 164 | .cNamedArgs = 0
|
---|
| 165 | End With
|
---|
[709] | 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)
|
---|
[175] | 169 | Dispose()
|
---|
| 170 | End Function
|
---|
| 171 |
|
---|
[335] | 172 | Sub Prop(arg As Variant)
|
---|
[175] | 173 | Prop(ByVal arg.PtrToVariant)
|
---|
| 174 | End Sub
|
---|
| 175 |
|
---|
| 176 | Sub Prop(ByRef arg As VARIANT)
|
---|
[192] | 177 | setProp(arg, DISPATCH_PROPERTYPUT)
|
---|
[175] | 178 | End Sub
|
---|
| 179 |
|
---|
[335] | 180 | Sub PropRef(arg As Variant)
|
---|
| 181 | PropRef(ByVal arg.PtrToVariant)
|
---|
[175] | 182 | End Sub
|
---|
| 183 |
|
---|
| 184 | Sub PropRef(ByRef arg As VARIANT)
|
---|
[192] | 185 | setProp(arg, DISPATCH_PROPERTYPUTREF)
|
---|
[175] | 186 | End Sub
|
---|
| 187 |
|
---|
| 188 | Function Call(cArgs As Long, args As *VARIANT) As Variant
|
---|
| 189 | Dim dispParams As DISPPARAMS
|
---|
| 190 | With dispParams
|
---|
| 191 | .rgvarg = args
|
---|
| 192 | .rgdispidNamedArgs = 0
|
---|
| 193 | .cArgs = cArgs
|
---|
| 194 | .cNamedArgs = 0
|
---|
| 195 | End With
|
---|
[709] | 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)
|
---|
[175] | 199 | Dispose()
|
---|
| 200 | End Function
|
---|
| 201 |
|
---|
| 202 | ' Function Call(cArgs As Long, args As *Variant) As Variant
|
---|
| 203 | ' End Function
|
---|
| 204 |
|
---|
| 205 | Function Call() As Variant
|
---|
| 206 | Return Call(0, 0)
|
---|
| 207 | End Function
|
---|
| 208 |
|
---|
[200] | 209 | Function Call(arg0 As Variant) As Variant
|
---|
| 210 | Return Call(1, arg0.PtrToVariant)
|
---|
[175] | 211 | End Function
|
---|
| 212 |
|
---|
[200] | 213 | Function Call(arg0 As Variant, arg1 As Variant) As Variant
|
---|
| 214 | Dim arg[ELM(2)] As VARIANT
|
---|
| 215 | arg[0] = arg0.Copy()
|
---|
| 216 | arg[1] = arg1.Copy()
|
---|
| 217 | Return Call(2, arg)
|
---|
| 218 | End Function
|
---|
[192] | 219 |
|
---|
[200] | 220 | Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant) As Variant
|
---|
| 221 | Dim arg[ELM(3)] As VARIANT
|
---|
| 222 | arg[0] = arg0.Copy()
|
---|
| 223 | arg[1] = arg1.Copy()
|
---|
| 224 | arg[2] = arg2.Copy()
|
---|
| 225 | Return Call(3, arg)
|
---|
[175] | 226 | End Function
|
---|
| 227 |
|
---|
[200] | 228 | Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant, arg3 As Variant) As Variant
|
---|
| 229 | Dim arg[ELM(4)] As VARIANT
|
---|
| 230 | arg[0] = arg0.Copy()
|
---|
| 231 | arg[1] = arg1.Copy()
|
---|
| 232 | arg[2] = arg2.Copy()
|
---|
| 233 | arg[3] = arg3.Copy()
|
---|
| 234 | Return Call(4, arg)
|
---|
| 235 | End Function
|
---|
| 236 |
|
---|
| 237 | /*
|
---|
| 238 | Function Call(arg0 = Variant.OptionalParam As Variant, arg1 = Variant.OptionalParam As Variant,
|
---|
| 239 | arg2 = Variant.OptionalParam As Variant, arg3 = Variant.OptionalParam As Variant,
|
---|
| 240 | arg4 = Variant.OptionalParam As Variant, arg5 = Variant.OptionalParam As Variant,
|
---|
| 241 | arg6 = Variant.OptionalParam As Variant, arg7 = Variant.OptionalParam As Variant,
|
---|
| 242 | arg8 = Variant.OptionalParam As Variant, arg9 = Variant.OptionalParam As Variant) As Variant
|
---|
| 243 | Dim arg[ELM(10)] As VARIANT
|
---|
| 244 | arg[0] = arg0.Copy()
|
---|
| 245 | arg[1] = arg1.Copy()
|
---|
| 246 | arg[2] = arg2.Copy()
|
---|
| 247 | arg[3] = arg3.Copy()
|
---|
| 248 | arg[4] = arg3.Copy()
|
---|
| 249 | arg[5] = arg4.Copy()
|
---|
| 250 | arg[6] = arg5.Copy()
|
---|
| 251 | arg[7] = arg6.Copy()
|
---|
| 252 | arg[8] = arg7.Copy()
|
---|
| 253 | arg[9] = arg8.Copy()
|
---|
| 254 | Return Call(10, arg)
|
---|
| 255 | End Function
|
---|
| 256 | */
|
---|
[175] | 257 | Private
|
---|
[192] | 258 | Sub setProp(ByRef arg As VARIANT, callType As Word)
|
---|
| 259 | Dim dispidNamed = DISPID_PROPERTYPUT As DISPID
|
---|
| 260 | Dim dispParams As DISPPARAMS
|
---|
| 261 | With dispParams
|
---|
| 262 | .rgvarg = VarPtr(arg)
|
---|
| 263 | .rgdispidNamedArgs = VarPtr(dispidNamed)
|
---|
| 264 | .cArgs = 1
|
---|
| 265 | .cNamedArgs = 1
|
---|
| 266 | End With
|
---|
[709] | 267 | Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
|
---|
| 268 | Windows.ThrowIfFailed(hr)
|
---|
[192] | 269 | Dispose()
|
---|
| 270 | End Sub
|
---|
| 271 |
|
---|
[709] | 272 | disp As IDispatch
|
---|
[175] | 273 | dispid As DISPID
|
---|
| 274 | End Class
|
---|
[192] | 275 |
|
---|
| 276 | Function CallByName(obj As VBObject, procName As String, callType As Word, cArgs As Long, args As *VARIANT) As Variant
|
---|
| 277 | Return CallByName(obj.Dispatch, ToWCStr(procName), callType, cArgs, args)
|
---|
| 278 | End Function
|
---|
| 279 |
|
---|
| 280 | Function CallByName(obj As VBObject, procName As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
|
---|
| 281 | Return CallByName(obj.Dispatch, procName, callType, cArgs, args)
|
---|
| 282 | End Function
|
---|
| 283 |
|
---|
[709] | 284 | Function CallByName(obj As IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
|
---|
[192] | 285 | Dim dispid As DISPID
|
---|
[709] | 286 | Dim hr = obj.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
|
---|
| 287 | Windows.ThrowIfFailed(hr)
|
---|
[192] | 288 | Dim dispParams As DISPPARAMS
|
---|
| 289 | With dispParams
|
---|
| 290 | .rgvarg = args
|
---|
| 291 | .rgdispidNamedArgs = 0
|
---|
| 292 | .cArgs = cArgs
|
---|
| 293 | .cNamedArgs = 0
|
---|
| 294 | End With
|
---|
[208] | 295 | CallByName = New Variant
|
---|
[709] | 296 | hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0)
|
---|
| 297 | Windows.ThrowIfFailed(hr)
|
---|
[192] | 298 | End Function
|
---|
[355] | 299 | /*
|
---|
[175] | 300 | Function CreateObject(className As PCWSTR) As VBObject
|
---|
[335] | 301 | Return New VBObject(className, 0, CLSCTX_ALL)
|
---|
[175] | 302 | End Function
|
---|
| 303 |
|
---|
| 304 | Function CreateObject(className As String) As VBObject
|
---|
[335] | 305 | Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
|
---|
[175] | 306 | End Function
|
---|
[709] | 307 | */
|
---|
[175] | 308 | #ifdef _WIN32_DCOM
|
---|
| 309 | Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
|
---|
| 310 | Dim clsid As CLSID
|
---|
| 311 | Dim si As COSERVERINFO
|
---|
| 312 | Dim context As DWord
|
---|
[709] | 313 | If /*Server = 0 OrElse*/ Server[0] = 0 Then
|
---|
[192] | 314 | context = CLSCTX_SERVER
|
---|
| 315 | Else
|
---|
| 316 | context = CLSCTX_REMOTE_SERVER
|
---|
| 317 | si.pwszName = serverName
|
---|
| 318 | End If
|
---|
[175] | 319 |
|
---|
| 320 | Dim hr = _System_CLSIDFromString(className, clsid)
|
---|
| 321 |
|
---|
| 322 | Dim mqi As MULTI_QI
|
---|
| 323 | mqi.pIID = VarPtr(IID_IUnknown)
|
---|
| 324 | hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
|
---|
| 325 | If SUCCEEDED(hr) Then
|
---|
| 326 | Dim obj As VBObject
|
---|
| 327 | obj.Attach(mqi.pItf As IDispatch)
|
---|
| 328 | Return obj
|
---|
| 329 | Else
|
---|
| 330 | 'Throw
|
---|
| 331 | Return Nothing
|
---|
| 332 | End If
|
---|
[192] | 333 | End Function
|
---|
[175] | 334 |
|
---|
| 335 | Function CreateObject(className As String, serverName As String) As VBObject
|
---|
| 336 | Return CreateObject(ToWCStr(className), ToWCStr(serverName))
|
---|
| 337 | End Function
|
---|
| 338 | #endif
|
---|
[709] | 339 |
|
---|
| 340 |
|
---|
| 341 | Namespace Detail
|
---|
| 342 | Function StringToCLSID(pwString As PCWSTR) As CLSID
|
---|
[175] | 343 | If pwString[0] = &h007b As WCHAR Then
|
---|
[192] | 344 | ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
|
---|
[709] | 345 | Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID))
|
---|
[192] | 346 | Else
|
---|
[709] | 347 | Windows.ThrowIfFailed(CLSIDFromProgID(pwString, StringToCLSID))
|
---|
[192] | 348 | End If
|
---|
[175] | 349 | End Function
|
---|
| 350 |
|
---|
[709] | 351 | Function COMReferenceEquals(p As IUnknown, q As IUnknown) As Boolean
|
---|
| 352 | If ObjPtr(p) = ObjPtr(q) Then
|
---|
[192] | 353 | Return True
|
---|
[709] | 354 | Else If ObjPtr(p) = 0 Or ObjPtr(q) = 0 Then
|
---|
[192] | 355 | Return False
|
---|
| 356 | End If
|
---|
| 357 |
|
---|
[709] | 358 | Dim punkX = GetUnknown(p)
|
---|
| 359 | Dim punkY = GetUnknown(q)
|
---|
| 360 | If ObjPtr(punkX) = ObjPtr(punkY) Then
|
---|
| 361 | COMReferenceEquals = True
|
---|
[192] | 362 | Else
|
---|
[709] | 363 | COMReferenceEquals = False
|
---|
[192] | 364 | End If
|
---|
[709] | 365 | punkX.Release()
|
---|
| 366 | punkY.Release()
|
---|
[192] | 367 | End Function
|
---|
| 368 |
|
---|
[709] | 369 | Function GetUnknown(p As IUnknown) As IUnknown 'pは任意のCOMインタフェース
|
---|
| 370 | If FAILED(p.QueryInterface(IID_IUnknown, GetUnknown)) Then
|
---|
| 371 | GetUnknown = Nothing
|
---|
[192] | 372 | End If
|
---|
| 373 | End Function
|
---|
[709] | 374 | End Namespace 'Detail
|
---|
[192] | 375 |
|
---|
[267] | 376 | End Namespace 'COM
|
---|
| 377 | End Namespace 'ActiveBasic
|
---|