source: Include/com/vbobject.ab@ 200

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

Currencyにメンバを追加
File size: 9.3 KB
Line 
1' com/vbobject.ab
2
3#ifndef _COM_VBIBJECT_AB
4#define _COM_VBIBJECT_AB
5
6#include <com/variant.ab>
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 Dim v = New Variant
160 v.Attach(ret)
161 Return v
162 End Function
163
164 Sub Prop(ByRef 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(ByRef arg As Variant)
173 PropRef(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.Attach(ret)
291 Return CallByName
292End Function
293
294Function CreateObject(className As PCWSTR) As VBObject
295 Return New VBObject(className)
296End Function
297
298Function CreateObject(className As String) As VBObject
299 Return New VBObject(ToWCStr(className))
300End Function
301/*
302#ifdef _WIN32_DCOM
303Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
304 Dim clsid As CLSID
305 Dim si As COSERVERINFO
306 Dim context As DWord
307 If /*Server = 0 OrElse* / Server[0] = 0 Then
308 context = CLSCTX_SERVER
309 Else
310 context = CLSCTX_REMOTE_SERVER
311 si.pwszName = serverName
312 End If
313
314 Dim hr = _System_CLSIDFromString(className, clsid)
315
316 Dim mqi As MULTI_QI
317 mqi.pIID = VarPtr(IID_IUnknown)
318 hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
319 If SUCCEEDED(hr) Then
320 Dim obj As VBObject
321 obj.Attach(mqi.pItf As IDispatch)
322 Return obj
323 Else
324 'Throw
325 Return Nothing
326 End If
327End Function
328
329Function CreateObject(className As String, serverName As String) As VBObject
330 Return CreateObject(ToWCStr(className), ToWCStr(serverName))
331End Function
332#endif
333*/
334Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT
335 If pwString[0] = &h007b As WCHAR Then
336 ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
337 _System_CLSIDFromString = CLSIDFromString(pwString, guid)
338 Else
339 _System_CLSIDFromString = CLSIDFromProgID(pwString, guid)
340 End If
341End Function
342
343Function _System_COMReferenceEquals(p As *IUnknown, q As *IUnknown) As Boolean
344 If p = q Then
345 Return True
346 Else If p = 0 Or q = 0 Then
347 Return False
348 End If
349
350 Dim punkX = _System_GetUnknown(p)
351 Dim punkY = _System_GetUnknown(q)
352 If punkX = punkY Then
353 _System_COMReferenceEquals = True
354 Else
355 _System_COMReferenceEquals = False
356 End If
357 punkX->Release()
358 punkY->Release()
359End Function
360
361Function _System_GetUnknown(p As *IUnknown) As *IUnknown 'pは任意のCOMインタフェース
362 If FAILDED(pdisp->QueryInterface(IID_Unknown, _System_GetUnknown)) Then
363 GetUnknown = 0
364 End If
365End Function
366
367#endif '_COM_VBIBJECT_AB
Note: See TracBrowser for help on using the repository browser.