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

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

FormatIntegerDを実装。
UnitTestの失敗時の表示を目立つようにした。
ArrayListを名前空間System.Collectionsに入れた。
File size: 9.4 KB
Line 
1' com/vbobject.ab
2
3#ifndef _COM_VBIBJECT_AB
4#define _COM_VBIBJECT_AB
5
6#include <com/variant.ab>
7
8Namespace ActiveBasic
9Namespace COM
10
11Class VBObject
12Public
13 Sub VBObject()
14 pdisp = 0
15 End Sub
16
17 Sub VBObject(className As String, pOuter As *IUnknown, clsContext As DWord)
18 VBObject(ToWCStr(className), pOuter, clsContext)
19 End Sub
20
21 Sub VBObject(className As PCSTR, pOuter As *IUnknown, clsContext As DWord)
22 VBObject(ToWCStr(className), pOuter, clsContext)
23 End Sub
24
25 Sub VBObject(className As PCWSTR, pOuter As *IUnknown, clsContext As DWord)
26 pdisp = 0
27 Dim clsid As CLSID
28 Dim hr = _System_CLSIDFromString(className, clsid)
29 VBObject(clsid, pOuter, clsContext)
30 End Sub
31
32 Sub VBObject(ByRef clsid As CLSID, pOuter As *IUnknown, clsContext As DWord)
33 Dim hr = CoCreateInstance(clsid, pOuter, clsContext, IID_IDispatch, pdisp)
34 End Sub
35
36 Sub VBObject(ByRef obj As VBObject)
37 pdisp = obj.pdisp
38 pdisp->AddRef()
39 End Sub
40
41 Sub ~VBObject()
42 Clear()
43 End Sub
44
45 Sub Clear()
46 If pdisp <> 0 Then
47 pdisp->Release()
48 pdisp = 0
49 End If
50 End Sub
51
52 Function Operator [](name As PCWSTR) As DispatchCaller
53 Return GetCaller(name)
54 End Function
55
56 Function Operator [](name As String) As DispatchCaller
57 Return GetCaller(ToWCStr(name))
58 End Function
59
60 Function Equals(y As VBObject) As Boolean
61 Return _System_COMReferenceEquals(pdisp, y.pdisp)
62 End Function
63/*
64 Override Function GetHashCode() As Long
65 Dim punk = _System_GetUnknown(pdisp)
66 GetHashCode = _System_HashFromPtr(punk)
67 punk->Release()
68 End Function
69*/
70 Function Operator ==(y As VBObject) As Boolean
71 Return Equals(y)
72 End Function
73
74 Function Operator <>(y As VBObject) As Boolean
75 Return Not Equals(y)
76 End Function
77
78 Sub Assign(p As *IDispatch)
79 Clear()
80 VBObject.Copy(pdisp, p)
81 End Sub
82
83 Function Copy() As *IDispatch
84 VBObject.Copy(GetDispatch, pdisp)
85 End Function
86
87 Sub Attach(ByRef p As *IDispatch)
88 Clear()
89 VBObject.Move(pdisp, p)
90 End Sub
91
92 Function Detach() As *IDispatch
93 VBObject.Move(Detach, pdisp)
94 End Function
95
96 Function Dispatch() As *IDispatch
97 Dispatch = pdisp
98 End Function
99Private
100 Function GetCaller(name As PCWSTR) As DispatchCaller
101 Dim dispid As DISPID
102 Dim hr = pdisp->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
103 Return New DispatchCaller(pdisp, dispid)
104 End Function
105
106 pdisp As *IDispatch
107
108 Static Sub Copy(ByRef dst As *IDispatch, ByVal src As *IDispatch)
109 dst = src
110 dst->AddRef()
111 End Sub
112
113 Static Sub Move(ByRef dst As *IDispatch, ByRef src As *IDispatch)
114 dst = src
115 src = 0
116 End Sub
117End Class
118
119Class DispatchCaller
120Public
121 Sub DispatchCaller()
122 End Sub
123 Sub DispatchCaller(pDispatch As *IDispatch, dispatchId As DISPID)
124 pdisp = pDispatch
125 pdisp->AddRef()
126 dispid = dispatchId
127 End Sub
128
129 Sub DispatchCaller(ByRef dc As DispatchCaller)
130 pdisp = dc.pdisp
131 pdisp->AddRef()
132 dispid = dc.dispid
133 End Sub
134
135 Sub Operator =(ByRef dc As DispatchCaller)
136 Dispose()
137 DispatchCaller(dc)
138 End Sub
139
140 Sub Dispose()
141 If pdisp <> 0 Then
142 pdisp->Release()
143 pdisp = 0
144 End If
145 End Sub
146
147 Sub ~DispatchCaller()
148 Dispose()
149 End Sub
150
151 Function Prop() As Variant
152 Dim dispParams As DISPPARAMS
153 With dispParams
154 .rgvarg = 0
155 .rgdispidNamedArgs = 0
156 .cArgs = 0
157 .cNamedArgs = 0
158 End With
159 Dim ret As VARIANT
160 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ret, 0, 0)
161 Dispose()
162 Prop = New Variant
163 v.Attach(ret)
164 Return v
165 End Function
166
167 Sub Prop(arg As Variant)
168 Prop(ByVal arg.PtrToVariant)
169 End Sub
170
171 Sub Prop(ByRef arg As VARIANT)
172 setProp(arg, DISPATCH_PROPERTYPUT)
173 End Sub
174
175 Sub PropRef(arg As Variant)
176 PropRef(ByVal arg.PtrToVariant)
177 End Sub
178
179 Sub PropRef(ByRef arg As VARIANT)
180 setProp(arg, DISPATCH_PROPERTYPUTREF)
181 End Sub
182
183 Function Call(cArgs As Long, args As *VARIANT) As Variant
184 Dim dispParams As DISPPARAMS
185 With dispParams
186 .rgvarg = args
187 .rgdispidNamedArgs = 0
188 .cArgs = cArgs
189 .cNamedArgs = 0
190 End With
191 Dim ret As VARIANT
192 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
193 Dispose()
194 Dim v = New Variant
195 v.Attach(ret)
196 Return v
197 End Function
198
199' Function Call(cArgs As Long, args As *Variant) As Variant
200' End Function
201
202 Function Call() As Variant
203 Return Call(0, 0)
204 End Function
205
206 Function Call(arg0 As Variant) As Variant
207 Return Call(1, arg0.PtrToVariant)
208 End Function
209
210 Function Call(arg0 As Variant, arg1 As Variant) As Variant
211 Dim arg[ELM(2)] As VARIANT
212 arg[0] = arg0.Copy()
213 arg[1] = arg1.Copy()
214 Return Call(2, arg)
215 End Function
216
217 Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant) As Variant
218 Dim arg[ELM(3)] As VARIANT
219 arg[0] = arg0.Copy()
220 arg[1] = arg1.Copy()
221 arg[2] = arg2.Copy()
222 Return Call(3, arg)
223 End Function
224
225 Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant, arg3 As Variant) As Variant
226 Dim arg[ELM(4)] As VARIANT
227 arg[0] = arg0.Copy()
228 arg[1] = arg1.Copy()
229 arg[2] = arg2.Copy()
230 arg[3] = arg3.Copy()
231 Return Call(4, arg)
232 End Function
233
234/*
235 Function Call(arg0 = Variant.OptionalParam As Variant, arg1 = Variant.OptionalParam As Variant,
236 arg2 = Variant.OptionalParam As Variant, arg3 = Variant.OptionalParam As Variant,
237 arg4 = Variant.OptionalParam As Variant, arg5 = Variant.OptionalParam As Variant,
238 arg6 = Variant.OptionalParam As Variant, arg7 = Variant.OptionalParam As Variant,
239 arg8 = Variant.OptionalParam As Variant, arg9 = Variant.OptionalParam As Variant) As Variant
240 Dim arg[ELM(10)] As VARIANT
241 arg[0] = arg0.Copy()
242 arg[1] = arg1.Copy()
243 arg[2] = arg2.Copy()
244 arg[3] = arg3.Copy()
245 arg[4] = arg3.Copy()
246 arg[5] = arg4.Copy()
247 arg[6] = arg5.Copy()
248 arg[7] = arg6.Copy()
249 arg[8] = arg7.Copy()
250 arg[9] = arg8.Copy()
251 Return Call(10, arg)
252 End Function
253*/
254Private
255 Sub setProp(ByRef arg As VARIANT, callType As Word)
256 Dim dispidNamed = DISPID_PROPERTYPUT As DISPID
257 Dim dispParams As DISPPARAMS
258 With dispParams
259 .rgvarg = VarPtr(arg)
260 .rgdispidNamedArgs = VarPtr(dispidNamed)
261 .cArgs = 1
262 .cNamedArgs = 1
263 End With
264 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
265 Dispose()
266 End Sub
267
268
269 pdisp As *IDispatch
270 dispid As DISPID
271End Class
272
273Function CallByName(obj As VBObject, procName As String, callType As Word, cArgs As Long, args As *VARIANT) As Variant
274 Return CallByName(obj.Dispatch, ToWCStr(procName), callType, cArgs, args)
275End Function
276
277Function CallByName(obj As VBObject, procName As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
278 Return CallByName(obj.Dispatch, procName, callType, cArgs, args)
279End Function
280
281Function CallByName(obj As *IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
282 Dim dispid As DISPID
283 Dim hr = obj->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
284 Dim dispParams As DISPPARAMS
285 With dispParams
286 .rgvarg = args
287 .rgdispidNamedArgs = 0
288 .cArgs = cArgs
289 .cNamedArgs = 0
290 End With
291 Dim ret As VARIANT
292 hr = obj->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
293 CallByName = New Variant
294 CallByName.Attach(ret)
295 Return CallByName
296End Function
297/*
298Function CreateObject(className As PCWSTR) As VBObject
299 Return New VBObject(className, 0, CLSCTX_ALL)
300End Function
301
302Function CreateObject(className As String) As VBObject
303 Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
304End Function
305/*
306#ifdef _WIN32_DCOM
307Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
308 Dim clsid As CLSID
309 Dim si As COSERVERINFO
310 Dim context As DWord
311 If /*Server = 0 OrElse* / Server[0] = 0 Then
312 context = CLSCTX_SERVER
313 Else
314 context = CLSCTX_REMOTE_SERVER
315 si.pwszName = serverName
316 End If
317
318 Dim hr = _System_CLSIDFromString(className, clsid)
319
320 Dim mqi As MULTI_QI
321 mqi.pIID = VarPtr(IID_IUnknown)
322 hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
323 If SUCCEEDED(hr) Then
324 Dim obj As VBObject
325 obj.Attach(mqi.pItf As IDispatch)
326 Return obj
327 Else
328 'Throw
329 Return Nothing
330 End If
331End Function
332
333Function CreateObject(className As String, serverName As String) As VBObject
334 Return CreateObject(ToWCStr(className), ToWCStr(serverName))
335End Function
336#endif
337*/
338Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT
339 If pwString[0] = &h007b As WCHAR Then
340 ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
341 _System_CLSIDFromString = CLSIDFromString(pwString, guid)
342 Else
343 _System_CLSIDFromString = CLSIDFromProgID(pwString, guid)
344 End If
345End Function
346
347Function _System_COMReferenceEquals(p As *IUnknown, q As *IUnknown) As Boolean
348 If p = q Then
349 Return True
350 Else If p = 0 Or q = 0 Then
351 Return False
352 End If
353
354 Dim punkX = _System_GetUnknown(p)
355 Dim punkY = _System_GetUnknown(q)
356 If punkX = punkY Then
357 _System_COMReferenceEquals = True
358 Else
359 _System_COMReferenceEquals = False
360 End If
361 punkX->Release()
362 punkY->Release()
363End Function
364
365Function _System_GetUnknown(p As *IUnknown) As *IUnknown 'pは任意のCOMインタフェース
366 If FAILDED(pdisp->QueryInterface(IID_Unknown, _System_GetUnknown)) Then
367 GetUnknown = 0
368 End If
369End Function
370
371End Namespace 'COM
372End Namespace 'ActiveBasic
373
374#endif '_COM_VBIBJECT_AB
Note: See TracBrowser for help on using the repository browser.