source: trunk/ab5.0/ablib/src/com/vbobject.ab @ 709

Last change on this file since 709 was 709, checked in by イグトランス (egtra), 14 years ago

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

File size: 9.7 KB
Line 
1' com/vbobject.ab
2
3#require <com/variant.ab>
4
5Namespace ActiveBasic
6Namespace COM
7
8Class VBObjectBase
9    Implements System.IDisposable, System.IEquatable<VBObjectBase>
10Public
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()
21    End Sub
22
23    Sub Clear()
24        Dispose()
25    End Sub
26
27    Virtual Sub Dispose()
28        If ObjPtr(disp) <> 0 Then
29            disp.Release()
30            disp = Nothing
31        End If
32    End Sub
33
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)
39    End Function
40/*
41    Override Function GetHashCode() As Long
42        Dim punk = _System_GetUnknown(pdisp)
43        GetHashCode = _System_HashFromPtr(punk)
44        punk->Release()
45    End Function
46*/
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)
67        Clear()
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
127Private
128    Function GetCaller(name As PCWSTR) As DispatchCaller
129        Dim dispid As DISPID
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
134End Class
135
136Class DispatchCaller
137    Implements System.IDisposable
138Public
139    Sub DispatchCaller()
140    End Sub
141    Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID)
142        disp = dispObj
143        disp.AddRef()
144        dispid = dispatchId
145    End Sub
146
147    Sub Dispose()
148        If ObjPtr(disp) <> NULL Then
149            disp.Release()
150            disp = Nothing
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
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()
170    End Function
171
172    Sub Prop(arg As Variant)
173        Prop(ByVal arg.PtrToVariant)
174    End Sub
175
176    Sub Prop(ByRef arg As VARIANT)
177        setProp(arg, DISPATCH_PROPERTYPUT)
178    End Sub
179
180    Sub PropRef(arg As Variant)
181        PropRef(ByVal arg.PtrToVariant)
182    End Sub
183
184    Sub PropRef(ByRef arg As VARIANT)
185        setProp(arg, DISPATCH_PROPERTYPUTREF)
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
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()
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
209    Function Call(arg0 As Variant) As Variant
210        Return Call(1, arg0.PtrToVariant)
211    End Function
212
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
219
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)
226    End Function
227
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*/
257Private
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
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
273    dispid As DISPID
274End Class
275
276Function 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)
278End Function
279
280Function 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)
282End Function
283
284Function CallByName(obj As IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
285    Dim dispid As DISPID
286    Dim hr = obj.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
287    Windows.ThrowIfFailed(hr)
288    Dim dispParams As DISPPARAMS
289    With dispParams
290        .rgvarg = args
291        .rgdispidNamedArgs = 0
292        .cArgs = cArgs
293        .cNamedArgs = 0
294    End With
295    CallByName = New Variant
296    hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0)
297    Windows.ThrowIfFailed(hr)
298End Function
299/*
300Function CreateObject(className As PCWSTR) As VBObject
301    Return New VBObject(className, 0, CLSCTX_ALL)
302End Function
303
304Function CreateObject(className As String) As VBObject
305    Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
306End Function
307*/
308#ifdef _WIN32_DCOM
309Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
310    Dim clsid As CLSID
311    Dim si As COSERVERINFO
312    Dim context As DWord
313    If /*Server = 0 OrElse*/ Server[0] = 0 Then
314        context = CLSCTX_SERVER
315    Else
316        context = CLSCTX_REMOTE_SERVER
317        si.pwszName = serverName
318    End If
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
333End Function
334
335Function CreateObject(className As String, serverName As String) As VBObject
336    Return CreateObject(ToWCStr(className), ToWCStr(serverName))
337End Function
338#endif
339
340
341Namespace Detail
342Function StringToCLSID(pwString As PCWSTR) As CLSID
343    If pwString[0] = &h007b As WCHAR Then
344        ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
345        Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID))
346    Else
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
353        Return True
354    Else If ObjPtr(p) = 0 Or ObjPtr(q) = 0 Then
355        Return False
356    End If
357
358    Dim punkX = GetUnknown(p)
359    Dim punkY = GetUnknown(q)
360    If ObjPtr(punkX) = ObjPtr(punkY) Then
361        COMReferenceEquals = True
362    Else
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
375
376End Namespace 'COM
377End Namespace 'ActiveBasic
Note: See TracBrowser for help on using the repository browser.