source: Include/com/vbobject.ab@ 175

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

Variant, VBObjectの追加
File size: 6.5 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)
15 VBObject(ToWCStr(className))
16 End Sub
17
18 Sub VBObject(className As PCWSTR)
19 pdisp = 0
20 Dim clsid As CLSID
21 Dim hr = _System_CLSIDFromString(className, clsid)
22 Dim hr2 = CoCreateInstance(clsid, 0, CLSCTX_ALL, IID_IDispatch, pdisp)
23 End Sub
24
25 Sub VBObject(ByRef obj As VBObject)
26 pdisp = obj.pdisp
27 pdisp->AddRef()
28 End Sub
29
30 Sub Operator =(ByRef obj As VBObject)
31 ~VBObject()
32 VBObject(obj)
33 End Sub
34
35 Sub ~VBObject()
36 Clear()
37 End Sub
38
39 Sub Clear()
40 If pdisp <> 0 Then
41 pdisp->Release()
42 pdisp = 0
43 End If
44 End Sub
45
46 Function Operator [](name As PCWSTR) As DispatchCaller
47 Return GetCaller(name)
48 End Function
49
50 Function Operator [](name As String) As DispatchCaller
51 Return GetCaller(ToWCStr(name))
52 End Function
53
54 Function Equals(y As VBObject) As Boolean
55 Dim punkX = GetUnknown()
56 Dim punkY = y.GetUnknown()
57 Equals = (punkX == punkY)
58 punkX->Release()
59 punkY->Release()
60 End Function
61/*
62 Override Function GetHashCode() As Long
63 Dim punk = GetUnknown()
64 GetHashCode = _System_HashFromPtr(punk)
65 punk->Release()
66 End Function
67*/
68 Function Operator ==(y As VBObject) As Boolean
69 Return Equals(y)
70 End Function
71
72 Function Operator <>(y As VBObject) As Boolean
73 Return Not Equals(y)
74 End Function
75
76 Sub Assign(p As *IDispatch)
77 Clear()
78 VBObject.Copy(pdisp, p)
79 End Sub
80
81 Function GetDispatch() As *IDispatch
82 VBObject.Copy(GetDispatch, pdisp)
83 End Function
84
85 Sub Attach(ByRef p As *IDispatch)
86 Clear()
87 VBObject.Move(pdisp, p)
88 End Sub
89
90 Sub Detach() As *IDispatch
91 VBObject.Move(Detach, pdisp)
92 End Sub
93Private
94 Function GetCaller(name As PCWSTR) As DispatchCaller
95 Dim dispid As DISPID
96 Dim hr = pdisp->GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
97 Return New DispatchCaller(pdisp, dispid)
98 End Function
99
100 Function GetUnknown() As *IUnknown
101 If FAILDED(pdisp->QueryInterface(IID_Unknown, GetUnknown)) Then
102 GetUnknown = 0
103 End If
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 Dim v = New Variant
163 v.Attach(ret)
164 Return v
165 End Function
166
167 Sub Prop(ByRef arg As Variant)
168 Prop(ByVal arg.PtrToVariant)
169 End Sub
170
171 Sub Prop(ByRef arg As VARIANT)
172 Dim dispParams As DISPPARAMS
173 With dispParams
174 .rgvarg = 1
175 .rgdispidNamedArgs = 0
176 .cArgs = VarPtr(arg)
177 .cNamedArgs = 0
178 End With
179 Dim ret As VARIANT
180 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYPUT, dispParams, ret, ByVal 0, 0)
181 Dispose()
182 End Sub
183
184 Sub PropRef(ByRef arg As Variant)
185 PropRef(arg.PtrToVariant)
186 End Sub
187
188 Sub PropRef(ByRef arg As VARIANT)
189 Dim dispParams As DISPPARAMS
190 With dispParams
191 .rgvarg = 1
192 .rgdispidNamedArgs = 0
193 .cArgs = VarPtr(arg)
194 .cNamedArgs = 0
195 End With
196 Dim ret As VARIANT
197 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYPUTREF, dispParams, ret, ByVal 0, 0)
198 Dispose()
199 End Sub
200
201 Function Call(cArgs As Long, args As *VARIANT) As Variant
202 Dim dispParams As DISPPARAMS
203 With dispParams
204 .rgvarg = args
205 .rgdispidNamedArgs = 0
206 .cArgs = cArgs
207 .cNamedArgs = 0
208 End With
209 Dim ret As VARIANT
210 Dim hr = pdisp->Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ret, ByVal 0, 0)
211 Dispose()
212 Dim v = New Variant
213 v.Attach(ret)
214 Return v
215 End Function
216
217' Function Call(cArgs As Long, args As *Variant) As Variant
218' End Function
219
220 Function Call() As Variant
221 Return Call(0, 0)
222 End Function
223
224 Function Call(arg1 As Variant) As Variant
225 Return Call(1, arg1.PtrToVariant)
226 End Function
227
228 Function Call(ByRef arg1 As Variant, ByRef arg2 As Variant) As Variant
229 Dim arg[1] As VARIANT
230
231 Return Call(2, VarPtr(arg1) As *VARIANT)
232 End Function
233
234Private
235 pdisp As *IDispatch
236 dispid As DISPID
237End Class
238/*
239Function CreateObject(className As PCWSTR) As VBObject
240 Return New VBObject(className)
241End Function
242
243Function CreateObject(className As String) As VBObject
244 Return New VBObject(ToWCStr(className))
245End Function
246
247#ifdef _WIN32_DCOM
248Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
249 Dim clsid As CLSID
250 Dim si As COSERVERINFO
251 Dim context As DWord
252 If /*Server = 0 OrElse* / Server[0] = 0 Then
253 context = CLSCTX_SERVER
254 Else
255 context = CLSCTX_REMOTE_SERVER
256 si.pwszName = serverName
257 End If
258
259 Dim hr = _System_CLSIDFromString(className, clsid)
260
261 Dim mqi As MULTI_QI
262 mqi.pIID = VarPtr(IID_IUnknown)
263 hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
264 If SUCCEEDED(hr) Then
265 Dim obj As VBObject
266 obj.Attach(mqi.pItf As IDispatch)
267 Return obj
268 Else
269 'Throw
270 Return Nothing
271 End If
272End Function
273
274Function CreateObject(className As String, serverName As String) As VBObject
275 Return CreateObject(ToWCStr(className), ToWCStr(serverName))
276End Function
277#endif
278*/
279Function _System_CLSIDFromString(pwString As PCWSTR, ByRef guid As GUID) As HRESULT
280 If pwString[0] = &h007b As WCHAR Then
281 ' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
282 _System_CLSIDFromString = CLSIDFromString(pwString, guid)
283 Else
284 _System_CLSIDFromString = CLSIDFromProgID(pwString, guid)
285 End If
286End Function
287
288#endif '_COM_VBIBJECT_AB
Note: See TracBrowser for help on using the repository browser.