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

Last change on this file since 497 was 497, checked in by イグトランス (egtra), 16 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.