source: trunk/Include/com/vbobject.ab @ 497

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

インクルードガードとその他不要な前処理定義などの削除
File size: 9.3 KB
Line 
1' com/vbobject.ab
2
3#require <com/variant.ab>
4
5Namespace ActiveBasic
6Namespace COM
7
8Class VBObject
9Public
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()
40    End Sub
41
42    Sub Clear()
43        If pdisp <> 0 Then
44            pdisp->Release()
45            pdisp = 0
46        End If
47    End Sub
48
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)
59    End Function
60/*
61    Override Function GetHashCode() As Long
62        Dim punk = _System_GetUnknown(pdisp)
63        GetHashCode = _System_HashFromPtr(punk)
64        punk->Release()
65    End Function
66*/
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)
76        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
96Private
97    Function GetCaller(name As PCWSTR) As DispatchCaller
98        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
114End Class
115
116Class DispatchCaller
117Public
118    Sub DispatchCaller()
119    End Sub
120    Sub DispatchCaller(pDispatch As *IDispatch, dispatchId As DISPID)
121        pdisp = pDispatch
122        pdisp->AddRef()
123        dispid = dispatchId
124    End Sub
125
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
137    Sub Dispose()
138        If pdisp <> 0 Then
139            pdisp->Release()
140            pdisp = 0
141        End If
142    End Sub
143
144    Sub ~DispatchCaller()
145        Dispose()
146    End Sub
147
148    Function Prop() As Variant
149        Dim dispParams As DISPPARAMS
150        With dispParams
151            .rgvarg = 0
152            .rgdispidNamedArgs = 0
153            .cArgs = 0
154            .cNamedArgs = 0
155        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
162    End Function
163
164    Sub Prop(arg As Variant)
165        Prop(ByVal arg.PtrToVariant)
166    End Sub
167
168    Sub Prop(ByRef arg As VARIANT)
169        setProp(arg, DISPATCH_PROPERTYPUT)
170    End Sub
171
172    Sub PropRef(arg As Variant)
173        PropRef(ByVal arg.PtrToVariant)
174    End Sub
175
176    Sub PropRef(ByRef arg As VARIANT)
177        setProp(arg, DISPATCH_PROPERTYPUTREF)
178    End Sub
179
180    Function Call(cArgs As Long, args As *VARIANT) As Variant
181        Dim dispParams As DISPPARAMS
182        With dispParams
183            .rgvarg = args
184            .rgdispidNamedArgs = 0
185            .cArgs = cArgs
186            .cNamedArgs = 0
187        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
194    End Function
195
196'   Function Call(cArgs As Long, args As *Variant) As Variant
197'   End Function
198
199    Function Call() As Variant
200        Return Call(0, 0)
201    End Function
202
203    Function Call(arg0 As Variant) As Variant
204        Return Call(1, arg0.PtrToVariant)
205    End Function
206
207    Function Call(arg0 As Variant, arg1 As Variant) As Variant
208        Dim arg[ELM(2)] As VARIANT
209        arg[0] = arg0.Copy()
210        arg[1] = arg1.Copy()
211        Return Call(2, arg)
212    End Function
213
214    Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant) As Variant
215        Dim arg[ELM(3)] As VARIANT
216        arg[0] = arg0.Copy()
217        arg[1] = arg1.Copy()
218        arg[2] = arg2.Copy()
219        Return Call(3, arg)
220    End Function
221
222    Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant, arg3 As Variant) As Variant
223        Dim arg[ELM(4)] As VARIANT
224        arg[0] = arg0.Copy()
225        arg[1] = arg1.Copy()
226        arg[2] = arg2.Copy()
227        arg[3] = arg3.Copy()
228        Return Call(4, arg)
229    End Function
230
231/*
232    Function Call(arg0 = Variant.OptionalParam As Variant, arg1 = Variant.OptionalParam As Variant,
233        arg2 = Variant.OptionalParam As Variant, arg3 = Variant.OptionalParam As Variant,
234        arg4 = Variant.OptionalParam As Variant, arg5 = Variant.OptionalParam As Variant,
235        arg6 = Variant.OptionalParam As Variant, arg7 = Variant.OptionalParam As Variant,
236        arg8 = Variant.OptionalParam As Variant, arg9 = Variant.OptionalParam As Variant) As Variant
237        Dim arg[ELM(10)] As VARIANT
238        arg[0] = arg0.Copy()
239        arg[1] = arg1.Copy()
240        arg[2] = arg2.Copy()
241        arg[3] = arg3.Copy()
242        arg[4] = arg3.Copy()
243        arg[5] = arg4.Copy()
244        arg[6] = arg5.Copy()
245        arg[7] = arg6.Copy()
246        arg[8] = arg7.Copy()
247        arg[9] = arg8.Copy()
248        Return Call(10, arg)
249    End Function
250*/
251Private
252    Sub setProp(ByRef arg As VARIANT, callType As Word)
253        Dim dispidNamed = DISPID_PROPERTYPUT As DISPID
254        Dim dispParams As DISPPARAMS
255        With dispParams
256            .rgvarg = VarPtr(arg)
257            .rgdispidNamedArgs = VarPtr(dispidNamed)
258            .cArgs = 1
259            .cNamedArgs = 1
260        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    dispid As DISPID
268End Class
269
270Function CallByName(obj As VBObject, procName As String, callType As Word, cArgs As Long, args As *VARIANT) As Variant
271    Return CallByName(obj.Dispatch, ToWCStr(procName), callType, cArgs, args)
272End Function
273
274Function CallByName(obj As VBObject, procName As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
275    Return CallByName(obj.Dispatch, procName, callType, cArgs, args)
276End Function
277
278Function CallByName(obj As *IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
279    Dim dispid As DISPID
280    Dim hr = obj->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
281    Dim dispParams As DISPPARAMS
282    With dispParams
283        .rgvarg = args
284        .rgdispidNamedArgs = 0
285        .cArgs = cArgs
286        .cNamedArgs = 0
287    End With
288    Dim ret As VARIANT
289    hr = obj->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
290    CallByName = New Variant
291    CallByName.Attach(ret)
292    Return CallByName
293End Function
294/*
295Function CreateObject(className As PCWSTR) As VBObject
296    Return New VBObject(className, 0, CLSCTX_ALL)
297End Function
298
299Function CreateObject(className As String) As VBObject
300    Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
301End Function
302/*
303#ifdef _WIN32_DCOM
304Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
305    Dim clsid As CLSID
306    Dim si As COSERVERINFO
307    Dim context As DWord
308    If /*Server = 0 OrElse* / Server[0] = 0 Then
309        context = CLSCTX_SERVER
310    Else
311        context = CLSCTX_REMOTE_SERVER
312        si.pwszName = serverName
313    End If
314
315    Dim hr = _System_CLSIDFromString(className, clsid)
316
317    Dim mqi As MULTI_QI
318    mqi.pIID = VarPtr(IID_IUnknown)
319    hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
320    If SUCCEEDED(hr) Then
321        Dim obj As VBObject
322        obj.Attach(mqi.pItf As IDispatch)
323        Return obj
324    Else
325        'Throw
326        Return Nothing
327    End If
328End Function
329
330Function CreateObject(className As String, serverName As String) As VBObject
331    Return CreateObject(ToWCStr(className), ToWCStr(serverName))
332End Function
333#endif
334*/
335Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT
336    If pwString[0] = &h007b As WCHAR Then
337        ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
338        _System_CLSIDFromString = CLSIDFromString(pwString, guid)
339    Else
340        _System_CLSIDFromString = CLSIDFromProgID(pwString, guid)
341    End If
342End Function
343
344Function _System_COMReferenceEquals(p As *IUnknown, q As *IUnknown) As Boolean
345    If p = q Then
346        Return True
347    Else If p = 0 Or q = 0 Then
348        Return False
349    End If
350
351    Dim punkX = _System_GetUnknown(p)
352    Dim punkY = _System_GetUnknown(q)
353    If punkX = punkY Then
354        _System_COMReferenceEquals = True
355    Else
356        _System_COMReferenceEquals = False
357    End If
358    punkX->Release()
359    punkY->Release()
360End Function
361
362Function _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
366End Function
367
368End Namespace 'COM
369End Namespace 'ActiveBasic
Note: See TracBrowser for help on using the repository browser.