├── .gitignore ├── CLRHost.cls ├── ExitHandler.bas ├── .editorconfig ├── LICENSE ├── README.md ├── ExitHandler.utf8.bas └── CLRHost.utf8.cls /.gitignore: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /CLRHost.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jet2jet/vb2clr/HEAD/CLRHost.cls -------------------------------------------------------------------------------- /ExitHandler.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jet2jet/vb2clr/HEAD/ExitHandler.bas -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | [*] 2 | charset = utf-8 3 | end_of_line = lf 4 | insert_final_newline = true 5 | indent_style = tab 6 | indent_size = 4 7 | root = true 8 | 9 | [{*.bas,*.cls,*.frm}] 10 | # Visual Basic files do not support UTF-8 11 | charset = unset 12 | end_of_line = crlf 13 | indent_style = space 14 | indent_size = 4 15 | 16 | [{*.utf8.bas,*.utf8.cls,*.utf8.frm}] 17 | charset = utf-8 18 | 19 | [{*.json,.bowerrc,.gitignore,.npmignore,.gitattributes,.editorconfig}] 20 | end_of_line = lf 21 | indent_style = space 22 | indent_size = 2 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2018 jet (ジェット) 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # vb2clr 2 | 3 | The helper class `CLRHost` for Visual Basic for Applications (VBA) 7.0, providing access to CLR (.NET Framework) assemblies and classes. 4 | 5 | **To use .NET (formerly .NET Core), consider using [vb2net](https://github.com/jet2jet/vb2net).** 6 | 7 | ## Requirements 8 | 9 | Visual Basic for Application 7.0 (included in Microsoft Office 2010 or higher) 10 | 11 | * ***(not tested)*** To use on Visual Basic 6.0, rewrite `LongPtr` to `Long` and remove all `PtrSafe` specifiers. 12 | 13 | ## Usage 14 | 15 | 1. Import [CLRHost.cls](./CLRHost.cls) and [ExitHandler.bas](./ExitHandler.bas) into your VB/VBA project 16 | 2. Add Type Library reference 'Common Runtime Language Execution Engine' (maybe version 2.4) and 'mscorlib.dll' 17 | 3. Write your code using `CLRHost` class 18 | 19 | ## Notes and Warnings 20 | 21 | * You should release the `CLRHost` instance or call `Terminate` method when you finish using CLR. 22 | * Unexpected behavior may occur due to living CLR instances if you don't release or terminate them. 23 | * If you pass `True` to `TerminateOnExit` parameter of `CLRHost.Initialize`, you must not stop the debugger when breaking or pausing the application. 24 | * The code in `ExitHandler` module cannot be run when stopped during pausing, and the application (including VBA host such as Excel) may cause crash. 25 | * Encodings of VB files are Shift-JIS; if you have problem with encodings, check `.utf8.*` files, remove Japanese comments, and import them. 26 | 27 | ## Example 28 | 29 | ``` 30 | Public Sub RegexSample() 31 | Dim host As New CLRHost 32 | Call host.Initialize(False) 33 | 34 | On Error Resume Next 35 | Dim asmSys As mscorlib.Assembly 36 | Set asmSys = host.CLRLoadAssembly("System, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089") 37 | 38 | Dim cobjRegex As mscorlib.Object 39 | Set cobjRegex = host.CLRCreateObjectWithParams("System.Text.RegularExpressions.Regex", _ 40 | "([0-9])+") 41 | 42 | Dim cobjColl As mscorlib.Object 43 | Set cobjColl = host.CLRInvokeMethod(cobjRegex, "Matches", "10 20 50 1234 98765") 44 | 45 | Dim vMatch As Variant 46 | For Each vMatch In host.ToEnumerable(cobjColl) 47 | Dim cobjMatch As mscorlib.Object 48 | Set cobjMatch = vMatch 49 | Debug.Print "Matches: "; host.CLRProperty(cobjMatch, "Value") 50 | Set cobjMatch = Nothing 51 | Next vMatch 52 | vMatch = Empty 53 | Set cobjColl = Nothing 54 | Set cobjRegex = Nothing 55 | 56 | 'Call host.Terminate 57 | Set host = Nothing 58 | End Sub 59 | ``` 60 | 61 | ## More details 62 | 63 | - (In Japanese) [Using CLR(.NET) from VB](https://www.pg-fl.jp/program/tips/vb2clr1.htm) 64 | 65 | ## Author 66 | 67 | jet (@jet2jet) 68 | 69 | ## License 70 | 71 | [New BSD License (or The 3-Clause BSD License)](./LICENSE) 72 | -------------------------------------------------------------------------------- /ExitHandler.utf8.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExitHandler" 2 | ' Copyright (C) 2018 jet 3 | ' For more information about license, see LICENSE. 4 | ' 5 | ' *** This file is not intended to use because written in UTF-8 *** 6 | ' 7 | ' Helper module for handling on application-exit 8 | Option Explicit 9 | 10 | Private Type IID 11 | Data1 As Long 12 | Data2 As Integer 13 | Data3 As Integer 14 | Data4(0 To 7) As Byte 15 | End Type 16 | 17 | ' インスタンスのデータ 18 | Private Type MyClassData 19 | vtblPtr As LongPtr 20 | RefCount As Long 21 | #If Win64 Then ' 64ビット版かどうか 22 | Padding As Long 23 | #End If 24 | End Type 25 | 26 | ' 仮想関数テーブルのデータ 27 | Private Type IUnknownVtbl 28 | QueryInterface As LongPtr 29 | AddRef As LongPtr 30 | Release As LongPtr 31 | End Type 32 | 33 | Private Const S_OK As Long = 0 34 | Private Const E_NOINTERFACE As Long = &H80004002 35 | Private Const E_POINTER As Long = &H80004003 36 | 37 | Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _ 38 | (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr) 39 | Public Declare PtrSafe Function GetProcessHeap Lib "kernel32.dll" () As LongPtr 40 | Public Declare PtrSafe Function HeapAlloc Lib "kernel32.dll" _ 41 | (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal dwBytes As LongPtr) As LongPtr 42 | Public Declare PtrSafe Function HeapFree Lib "kernel32.dll" _ 43 | (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal lpMem As LongPtr) As Boolean 44 | 45 | Public Declare PtrSafe Function CoTaskMemAlloc Lib "ole32.dll" _ 46 | (ByVal cb As LongPtr) As LongPtr 47 | Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" _ 48 | (ByVal pv As LongPtr) 49 | 50 | ' VBA実行中は自前インスタンスが入り続ける変数 51 | Dim m_unk As IUnknown 52 | Dim m_collHandlers As Collection 53 | 54 | ' 変数に関数アドレスを代入するために用いる関数 55 | Private Function GetAddressOf(ByVal func As LongPtr) As LongPtr 56 | GetAddressOf = func 57 | End Function 58 | 59 | ' MyClassData と IUnknownVtbl のサイズを合わせたデータを指すポインターを返す 60 | Private Function CreateInstanceMemory() As LongPtr 61 | Dim p As LongPtr, d As MyClassData, v As IUnknownVtbl 62 | ' MyClassData と IUnknownVtbl のサイズを合わせたデータを作成 63 | p = CoTaskMemAlloc(Len(d) + Len(v)) 64 | If p <> 0 Then 65 | ' 最初の参照カウントは必ず 1 とする 66 | d.RefCount = 1 67 | ' MyClassData の直後に IUnknownVtbl を置くので p に MyClassData のサイズを加えたアドレスをセットする 68 | d.vtblPtr = p + Len(d) 69 | ' 割り当てたメモリブロックの先頭を MyClassData のデータで埋める 70 | Call CopyMemory(ByVal p, d, Len(d)) 71 | ' 仮想関数テーブルの作成 72 | v.QueryInterface = GetAddressOf(AddressOf My_QueryInterface) 73 | v.AddRef = GetAddressOf(AddressOf My_AddRef) 74 | v.Release = GetAddressOf(AddressOf My_Release) 75 | ' 仮想関数テーブルを p + Len(d) の部分にコピー 76 | Call CopyMemory(ByVal d.vtblPtr, v, Len(v)) 77 | End If 78 | CreateInstanceMemory = p 79 | End Function 80 | 81 | ' HRESULT STDMETHODCALLTYPE QueryInterface(THIS_ REFIID refiid, LPVOID FAR* ppv) 82 | ' 別のインターフェイスへ変換するのをリクエストするときに呼び出される関数 83 | ' (ppv は念のため NULL チェックを入れるため ByVal で定義) 84 | Private Function My_QueryInterface(ByVal This As LongPtr, ByRef refiid As IID, ByVal ppv As LongPtr) As Long 85 | Debug.Print "My_QueryInterface" 86 | If ppv = 0 Then 87 | Debug.Print " E_POINTER" 88 | My_QueryInterface = E_POINTER 89 | Exit Function 90 | End If 91 | ' IID_IUnknown: {00000000-0000-0000-C000-000000000046} かどうか確認 92 | If refiid.Data1 = 0 And refiid.Data2 = 0 And refiid.Data3 = 0 And _ 93 | refiid.Data4(0) = &HC0 And refiid.Data4(1) = 0 And _ 94 | refiid.Data4(2) = 0 And refiid.Data4(3) = 0 And _ 95 | refiid.Data4(4) = 0 And refiid.Data4(5) = 0 And _ 96 | refiid.Data4(6) = 0 And refiid.Data4(7) = 0 Then 97 | ' IID_IUnknown の場合は ppv が指すポインターの先に This のアドレス(This の値)をコピー 98 | Debug.Print " IID_IUnknown" 99 | Call CopyMemory(ByVal ppv, This, Len(This)) 100 | ' さらに参照カウントを増やす 101 | Call My_AddRef(This) 102 | My_QueryInterface = S_OK 103 | Exit Function 104 | End If 105 | ' IID_IUnknown 以外はサポートしない 106 | Debug.Print " E_NOINTERFACE" 107 | My_QueryInterface = E_NOINTERFACE 108 | End Function 109 | 110 | ' ULONG STDMETHODCALLTYPE AddRef(THIS) 111 | ' 参照カウントを増やす際に呼び出される関数 112 | Private Function My_AddRef(ByVal This As LongPtr) As Long 113 | Dim d As MyClassData 114 | ' インスタンスのデータを一旦 d にコピーし、 115 | ' 参照カウントを増やしたら書き戻す 116 | Call CopyMemory(d, ByVal This, Len(d)) 117 | d.RefCount = d.RefCount + 1 118 | Debug.Print "My_AddRef: new RefCount ="; d.RefCount 119 | Call CopyMemory(ByVal This, d, Len(d)) 120 | ' 戻り値は参照カウント 121 | My_AddRef = d.RefCount 122 | End Function 123 | 124 | ' ULONG STDMETHODCALLTYPE Release(THIS) 125 | ' 参照カウントを減らす際に呼び出される関数(0 になったら破棄) 126 | Private Function My_Release(ByVal This As LongPtr) As Long 127 | Dim d As MyClassData 128 | ' インスタンスのデータを一旦 d にコピーし、 129 | ' 参照カウントを減らしたら書き戻す 130 | Call CopyMemory(d, ByVal This, Len(d)) 131 | d.RefCount = d.RefCount - 1 132 | Debug.Print "My_Release: new RefCount ="; d.RefCount 133 | Call CopyMemory(ByVal This, d, Len(d)) 134 | ' 参照カウントが 0 になったら CoTaskMemFree で破棄する 135 | If d.RefCount = 0 Then 136 | Call CoTaskMemFree(This) 137 | ' 終了関数を呼び出す 138 | Call OnExit 139 | End If 140 | ' 戻り値は参照カウント 141 | My_Release = d.RefCount 142 | End Function 143 | 144 | ' 終了時に Handler.OnExit() が呼び出されるように 145 | ' Handler オブジェクトを登録 146 | Public Function AddExitHandler(ByVal Handler As Object, Optional ByVal Key As String) As Object 147 | Dim ptr As LongPtr 148 | If Not m_collHandlers Is Nothing Then 149 | On Error Resume Next 150 | Dim o As Object 151 | ptr = 0 152 | ptr = m_collHandlers.Item(Key) 153 | On Error GoTo 0 154 | If ptr <> 0 Then 155 | Call CopyMemory(o, ptr, Len(ptr)) 156 | Set AddExitHandler = o 157 | ptr = 0 158 | Call CopyMemory(o, ptr, Len(ptr)) 159 | Exit Function 160 | End If 161 | End If 162 | If m_unk Is Nothing Then 163 | Dim p As LongPtr 164 | ' インスタンスを作成 165 | p = CreateInstanceMemory() 166 | If p = 0 Then Exit Function 167 | Dim unk As IUnknown 168 | ' unk を p が指すインスタンスに設定 169 | Call CopyMemory(unk, p, Len(p)) 170 | ' m_unk にセット(内部で My_AddRef が呼び出される) 171 | Set m_unk = unk 172 | Set m_collHandlers = New Collection 173 | End If 174 | Call CopyMemory(ptr, Handler, Len(ptr)) 175 | Call m_collHandlers.Add(ptr, Key) 176 | Set AddExitHandler = Handler 177 | End Function 178 | 179 | Public Sub RemoveExitHandler(ByVal Handler As Variant) 180 | If m_collHandlers Is Nothing Then Exit Sub 181 | If VarType(Handler) = vbString Then 182 | On Error Resume Next 183 | Call m_collHandlers.Remove(Handler) 184 | Exit Sub 185 | End If 186 | If VarType(Handler) <> vbObject And VarType(Handler) <> 13 Then 187 | Call Err.Raise(13) 188 | End If 189 | Dim ptr As LongPtr, i As Long 190 | On Error Resume Next 191 | For i = 1 To m_collHandlers.Count 192 | ptr = m_collHandlers.Item(i) 193 | If ptr = ObjPtr(Handler) Then 194 | Call m_collHandlers.Remove(i) 195 | Exit For 196 | End If 197 | Next i 198 | End Sub 199 | 200 | ' VBA終了時の処理を記述 201 | Private Sub OnExit() 202 | Dim o As Object 203 | On Error Resume Next 204 | For Each o In m_collHandlers 205 | Call o.OnExit 206 | Next o 207 | End Sub 208 | -------------------------------------------------------------------------------- /CLRHost.utf8.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CLRHost" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (C) 2018 jet 11 | ' For more information about license, see LICENSE. 12 | ' 13 | ' *** This file is not intended to use because written in UTF-8 *** 14 | ' 15 | ' Defines CLRHost class 16 | Option Explicit 17 | 18 | Private Declare PtrSafe Function VariantCopy Lib "oleaut32.dll" _ 19 | (ByRef pvargDest As Variant, ByRef pvargSrc As Variant) As Long 20 | Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" _ 21 | (ByVal pvInstance As LongPtr, _ 22 | ByVal oVft As LongPtr, _ 23 | ByVal cc As Long, _ 24 | ByVal vtReturn As Integer, _ 25 | ByVal cActuals As Long, _ 26 | ByRef prgvt As Integer, _ 27 | ByRef prgpvarg As LongPtr, _ 28 | ByRef pvargResult As Variant) As Long 29 | 30 | Private Declare PtrSafe Function CLRCreateInstance Lib "mscoree.dll" _ 31 | (ByRef rclsid As Any, ByRef riid As Any, ByRef ppvInterface As IUnknown) As Long 32 | 33 | Dim m_host As mscoree.CorRuntimeHost 34 | Dim m_domain As mscorlib.AppDomain 35 | Dim m_asmCore As mscorlib.Assembly 36 | Dim m_typeObject As mscorlib.Type 37 | Dim m_objManagedSupport As Object 38 | Dim m_collTypeCache As Collection 39 | 40 | Private Sub Class_Terminate() 41 | Call CleanupImpl 42 | End Sub 43 | 44 | Private Sub CleanupImpl() 45 | If Not m_host Is Nothing Then 46 | Set m_collTypeCache = Nothing 47 | Set m_objManagedSupport = Nothing 48 | Set m_typeObject = Nothing 49 | Set m_asmCore = Nothing 50 | Call m_host.UnloadDomain(m_domain) 51 | Set m_domain = Nothing 52 | Call m_host.Stop 53 | Set m_host = Nothing 54 | Call RemoveExitHandler(Me) 55 | End If 56 | End Sub 57 | 58 | ' Parses GUID in string format into an array of Long. 59 | ' The array can be used as a pointer to GUID structure data. 60 | Public Sub ParseGUID(ByRef lnGUID() As Long, ByVal str As String) 61 | If Left$(str, 1) = "{" Then 62 | If Right$(str, 1) <> "}" Then Call Err.Raise(5) 63 | str = Mid$(str, 2, Len(str) - 2) 64 | End If 65 | If Len(str) <> 8 + 4 + 4 + 4 + 12 + 4 Then Call Err.Raise(5) 66 | Dim parts() As String 67 | parts = Split(str, "-") 68 | If LBound(parts) <> 0 Or UBound(parts) <> 4 Then Call Err.Raise(5) 69 | If Len(parts(0)) <> 8 Then Call Err.Raise(5) 70 | If Len(parts(1)) <> 4 Then Call Err.Raise(5) 71 | If Len(parts(2)) <> 4 Then Call Err.Raise(5) 72 | If Len(parts(3)) <> 4 Then Call Err.Raise(5) 73 | If Len(parts(4)) <> 12 Then Call Err.Raise(5) 74 | lnGUID(0) = CLng("&H" + parts(0)) 75 | lnGUID(1) = CLng("&H" + parts(2) + parts(1)) 76 | lnGUID(2) = CLng("&H" + Mid$(parts(4), 3, 2) + Mid$(parts(4), 1, 2) + Right$(parts(3), 2) + Left$(parts(3), 2)) 77 | lnGUID(3) = CLng("&H" + Mid$(parts(4), 11, 2) + Mid$(parts(4), 9, 2) + Mid$(parts(4), 7, 2) + Mid$(parts(4), 5, 2)) 78 | End Sub 79 | 80 | ' Call object's method with index of vftable 81 | Private Function VBCallAbsoluteObject(ByVal Object As IUnknown, _ 82 | ByVal IndexForVftable As Integer, _ 83 | ByVal RetType As VbVarType, _ 84 | ParamArray Arguments() As Variant) As Variant 85 | If Object Is Nothing Then 86 | Call Err.Raise(5) 87 | End If 88 | Dim hr As Long 89 | Dim argVt() As Integer 90 | Dim argsPtr() As LongPtr 91 | Dim i As Long, c As Long 92 | Dim lb As Long, ub As Long 93 | lb = LBound(Arguments) 94 | ub = UBound(Arguments) 95 | c = ub - lb + 1 96 | If c > 0 Then 97 | ReDim argVt(lb To ub) 98 | ReDim argsPtr(lb To ub) 99 | For i = lb To ub 100 | argVt(i) = VarType(Arguments(i)) 101 | argsPtr(i) = VarPtr(Arguments(i)) 102 | Next i 103 | hr = DispCallFunc(ObjPtr(Object), _ 104 | CLngPtr(IndexForVftable) * Len(argsPtr(0)), _ 105 | 4, _ 106 | CInt(RetType), _ 107 | c, _ 108 | argVt(lb), _ 109 | argsPtr(lb), _ 110 | VBCallAbsoluteObject) 111 | Else 112 | ReDim argVt(0) 113 | ReDim argsPtr(0) 114 | hr = DispCallFunc(ObjPtr(Object), _ 115 | CLngPtr(IndexForVftable) * Len(argsPtr(0)), _ 116 | 4, _ 117 | CInt(RetType), _ 118 | 0, _ 119 | argVt(0), _ 120 | argsPtr(0), _ 121 | VBCallAbsoluteObject) 122 | End If 123 | If hr < 0 Then Call Err.Raise(hr) 124 | End Function 125 | 126 | Private Function CreateCorRuntimeHost(ByVal Version As String) As mscoree.CorRuntimeHost 127 | Dim g(0 To 3) As Long 128 | Dim g2(0 To 3) As Long 129 | Dim pMetaHost As IUnknown, hr As Long 130 | Call ParseGUID(g, "{9280188D-0E8E-4867-B30C-7FA83884E8DE}") ' CLSID_CLRMetaHost 131 | Call ParseGUID(g2, "{D332DB9E-B9B3-4125-8207-A14884F53216}") ' IID_ICLRMetaHost 132 | hr = CLRCreateInstance(g(0), g2(0), pMetaHost) 133 | If hr < 0 Then Call Err.Raise(hr) 134 | 135 | Dim pRuntimeInfo As IUnknown 136 | Call ParseGUID(g, "{BD39D1D2-BA2F-486A-89B0-B4B0CB466891}") ' IID_ICLRRuntimeInfo 137 | ' ICLRMetaHost::GetRuntime(LPCWSTR, REFIID, void**) [vftable index = 3] 138 | hr = VBCallAbsoluteObject(pMetaHost, 3, vbLong, _ 139 | StrPtr(Version), VarPtr(g(0)), VarPtr(pRuntimeInfo)) 140 | Set pMetaHost = Nothing 141 | If hr < 0 Then Call Err.Raise(hr) 142 | 143 | Dim pCorRuntimeHost As IUnknown 144 | ' ICLRRuntimeInfo::GetInterface(REFCLSID, REFIID, void**) [vftable index = 9] 145 | Call ParseGUID(g, "{CB2F6723-AB3A-11D2-9C40-00C04FA30A3E}") ' CLSID_CorRuntimeHost 146 | Call ParseGUID(g2, "{CB2F6722-AB3A-11D2-9C40-00C04FA30A3E}") ' IID_ICorRuntimeHost 147 | hr = VBCallAbsoluteObject(pRuntimeInfo, 9, vbLong, _ 148 | VarPtr(g(0)), VarPtr(g2(0)), VarPtr(pCorRuntimeHost)) 149 | Set pRuntimeInfo = Nothing 150 | If hr < 0 Then Call Err.Raise(hr) 151 | Set CreateCorRuntimeHost = pCorRuntimeHost 152 | End Function 153 | 154 | Private Function GetCLRTypeFromInheritancesByMemberName(ByVal t As mscorlib.Type, ByVal MemberName As String, ByVal MemberType As mscorlib.MemberTypes) As mscorlib.Type 155 | Dim arrM() As mscorlib.MemberInfo 156 | Dim mi As mscorlib.MemberInfo, lb As Long, ub As Long, i As Long 157 | arrM = t.GetMembers_2() 158 | lb = LBound(arrM) 159 | ub = UBound(arrM) 160 | For i = lb To ub 161 | Set mi = arrM(i) 162 | If mi.Name = MemberName And (mi.MemberType And MemberTypes_All) <> 0 Then 163 | Set GetCLRTypeFromInheritancesByMemberName = t 164 | Exit Function 165 | End If 166 | Next i 167 | If t.BaseType Is Nothing Then 168 | Set GetCLRTypeFromInheritancesByMemberName = Nothing 169 | Exit Function 170 | End If 171 | Set GetCLRTypeFromInheritancesByMemberName = GetCLRTypeFromInheritancesByMemberName(t.BaseType, MemberName, MemberType) 172 | End Function 173 | 174 | Private Function ExecuteCSharpCode(ByVal domain As mscorlib.AppDomain, ByVal code As String, _ 175 | ParamArray RefAssemblyName() As Variant) As mscorlib.Assembly 176 | Dim asmSys As mscorlib.Assembly, o As Object 177 | 'Set asmSys = domain.Load_2("System.dll") 178 | Set asmSys = domain.Load_2("System, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089") 179 | Dim cobjParams As mscorlib.Object 180 | Set cobjParams = asmSys.CreateInstance("System.CodeDom.Compiler.CompilerParameters") 181 | Set o = cobjParams 182 | o.GenerateInMemory = True 183 | Dim v As Variant 184 | Dim oRefAsms As Object 185 | Set oRefAsms = ToObject(o.ReferencedAssemblies) 186 | For Each v In RefAssemblyName 187 | Call oRefAsms.Add(CStr(v)) 188 | Next v 189 | Dim cobjProvider As mscorlib.Object 190 | Dim vCodes(0) As String 191 | Set cobjProvider = asmSys.CreateInstance("Microsoft.CSharp.CSharpCodeProvider") 192 | Set o = cobjProvider 193 | vCodes(0) = code 194 | Dim cobjResults As mscorlib.Object 195 | Set cobjResults = o.CompileAssemblyFromSource(cobjParams, vCodes) 196 | Set o = cobjResults 197 | Dim oErrors As Object 198 | Set oErrors = ToObject(o.Errors) 199 | If oErrors.HasErrors Then 200 | Dim oError As Object 201 | Dim c As Long, i As Long 202 | c = oErrors.Count - 1 203 | For i = 0 To c 204 | Set oError = ToObject(oErrors.Item(i)) 205 | Debug.Print oError.ErrorText; " [Line="; oError.Line; "]" 206 | Next i 207 | Exit Function 208 | End If 209 | Set ExecuteCSharpCode = o.CompiledAssembly 210 | End Function 211 | 212 | Private Function IsType(ByRef v As Variant) As Boolean 213 | IsType = (VarType(v) = 13 And TypeOf v Is mscorlib.Type) 214 | End Function 215 | 216 | ' PickupMethodByParamTypeImpl: 型「t」に含まれる名前「Name」のメソッドを検索します。 217 | ' BindingFlags: 絞り込み条件 218 | ' Types: メソッドの引数に対応する型を表す mscorlib.Type のインスタンス。 219 | ' 対応する引数の数だけ指定します。 220 | ' 戻り値: mscorlib.MethodInfo のインスタンス、または見つからない場合 Nothing 221 | Private Function PickupMethodByParamTypeImpl(ByVal t As mscorlib.Type, ByVal Name As String, ByVal BindingFlags As mscorlib.BindingFlags, ByRef Types() As Variant) As mscorlib.MethodInfo 222 | Dim tlb As Long, tub As Long 223 | Dim actualTypeCount As Long 224 | Dim i As Long 225 | tlb = LBound(Types) 226 | tub = UBound(Types) 227 | actualTypeCount = 0 228 | ' 可変長引数で指定された Type インスタンスの数を計算 229 | For i = tlb To tub 230 | ' Types(i) が Type インスタンスかどうかを判定 231 | ' (13 は VT_UNKNOWN、mscorlib.Type は IUnknown ベースの型のため念のためチェック) 232 | If IsType(Types(i)) Then 233 | actualTypeCount = actualTypeCount + 1 234 | End If 235 | Next i 236 | 237 | Dim mis() As mscorlib.MethodInfo, mi As mscorlib.MethodInfo 238 | Dim j As Long, k As Long, Matched As Boolean 239 | ' BindingFlags で対応するメソッドの一覧を取得 240 | mis = t.GetMethods(BindingFlags) 241 | ' それぞれのメソッドに対し、メソッド名と引数の型をチェック 242 | For i = LBound(mis) To UBound(mis) 243 | Set mi = mis(i) 244 | ' メソッド名を Option Compare ステートメント設定に応じた比較方法で判定 245 | ' (大文字・小文字の区別を制御したい場合は StrComp 関数を用います。) 246 | If mi.Name = Name Then 247 | Dim p() As mscorlib.ParameterInfo 248 | ' 引数情報を取得(配列が返ります) 249 | p = mi.GetParameters() 250 | ' 引数の数の一致性を確認 251 | If UBound(p) - LBound(p) + 1 = actualTypeCount Then 252 | Matched = True 253 | k = LBound(p) 254 | For j = tlb To tub 255 | If IsType(Types(j)) Then 256 | Dim objPI As mscorlib.Object 257 | Dim o As Object, tP As mscorlib.Type 258 | ' ParameterInfo クラスの ParameterType プロパティーを見るため、 259 | ' mscorlib.Object 経由で VB の Object 型に変換 260 | Set objPI = p(k) 261 | Set o = objPI 262 | Set tP = o.ParameterType 263 | ' 型が一致しない引数が一つでもあった場合は不一致とする 264 | If Not tP.Equals(Types(j)) Then 265 | Matched = False 266 | Exit For 267 | End If 268 | k = k + 1 269 | End If 270 | Next j 271 | ' 一致した場合は見つかったものとしてループを抜ける 272 | If Matched Then Exit For 273 | End If 274 | End If 275 | Set mi = Nothing 276 | Next i 277 | Set PickupMethodByParamTypeImpl = mi 278 | End Function 279 | 280 | Private Function PickupMethodByParamType(ByVal t As mscorlib.Type, ByVal Name As String, ByVal BindingFlags As mscorlib.BindingFlags, ParamArray Types() As Variant) As mscorlib.MethodInfo 281 | Dim v() As Variant 282 | v = Types 283 | Set PickupMethodByParamType = PickupMethodByParamTypeImpl(t, Name, BindingFlags, v) 284 | End Function 285 | 286 | Private Function CreateManagedSupportObject(ByVal domain As mscorlib.AppDomain) As Object 287 | Dim asm As mscorlib.Assembly 288 | Dim rName As String, rIName As String 289 | Dim code As String 290 | rIName = "VBVariableDelegateWrapper_" + CStr(Int(Rnd() * 16384)) 291 | rName = "VBManagedSupport_" + CStr(Int(Rnd() * 16384)) 292 | code = "" + _ 293 | "using System;" + vbCrLf + _ 294 | "using System.Reflection;" + vbCrLf + _ 295 | "using System.Runtime.InteropServices;" + vbCrLf 296 | ' class VBVariableDelegateWrapper 297 | ' handles any delegate types using methods with different parameter count 298 | code = code + "class " + rIName + vbCrLf + _ 299 | "{" + vbCrLf + _ 300 | " private object _target;" + vbCrLf + _ 301 | " private Type _typeTarget;" + vbCrLf + _ 302 | " private string _methodName;" + vbCrLf + _ 303 | "" + vbCrLf + _ 304 | " public static Delegate CreateDelegate(Type delegateType, object target, string methodName)" + vbCrLf + _ 305 | " {" + vbCrLf + _ 306 | " return CreateDelegate(delegateType, target, target.GetType(), methodName);" + vbCrLf + _ 307 | " }" + vbCrLf + _ 308 | "" + vbCrLf + _ 309 | " public static Delegate CreateDelegate(Type delegateType, object target, Type targetType, string methodName)" + vbCrLf + _ 310 | " {" + vbCrLf + _ 311 | " if (!delegateType.IsSubclassOf(typeof(Delegate)))" + vbCrLf + _ 312 | " {" + vbCrLf + _ 313 | " throw new ArgumentException(""Invalid 'delegateType'"");" + vbCrLf 314 | code = code + " }" + vbCrLf + _ 315 | " var miInvoke = delegateType.GetMethod(""Invoke"");" + vbCrLf + _ 316 | " if (miInvoke == null)" + vbCrLf + _ 317 | " {" + vbCrLf + _ 318 | " throw new ArgumentException(""Invalid 'delegateType'"");" + vbCrLf + _ 319 | " }" + vbCrLf + _ 320 | " var c = miInvoke.GetParameters().Length;" + vbCrLf + _ 321 | " if (c > 19)" + vbCrLf + _ 322 | " {" + vbCrLf + _ 323 | " throw new NotSupportedException(""Parameter count of delegate is too large (maximum support = 19)"");" + vbCrLf + _ 324 | " }" + vbCrLf + _ 325 | " var wrapper = new " + rIName + "(target, targetType, methodName);" + vbCrLf + _ 326 | " var miWrapper = typeof(" + rIName + ").GetMethod(" + vbCrLf + _ 327 | " (miInvoke.ReturnType == typeof(void) ? ""VMethod"" : ""Method"") + c.ToString()," + vbCrLf + _ 328 | " BindingFlags.NonPublic | BindingFlags.Instance" + vbCrLf + _ 329 | " );" + vbCrLf + _ 330 | " return Delegate.CreateDelegate(delegateType, wrapper, miWrapper);" + vbCrLf + _ 331 | " }" + vbCrLf + _ 332 | "" + vbCrLf + _ 333 | " private " + rIName + "(object target, Type targetType, string methodName)" + vbCrLf 334 | code = code + " {" + vbCrLf + _ 335 | " _target = target;" + vbCrLf + _ 336 | " _typeTarget = targetType;" + vbCrLf + _ 337 | " _methodName = methodName;" + vbCrLf + _ 338 | " }" + vbCrLf + _ 339 | "" + vbCrLf + _ 340 | " private object Method(object[] args)" + vbCrLf + _ 341 | " {" + vbCrLf + _ 342 | " return _typeTarget.InvokeMember(_methodName," + vbCrLf + _ 343 | " BindingFlags.InvokeMethod | BindingFlags.OptionalParamBinding," + vbCrLf + _ 344 | " null, _target, args);" + vbCrLf + _ 345 | " }" + vbCrLf + _ 346 | " private object Method0() { return Method(new object[] { }); }" + vbCrLf + _ 347 | " private object Method1(object p1) { return Method(new object[] { p1 }); }" + vbCrLf + _ 348 | " private object Method2(object p1, object p2) { return Method(new object[] { p1, p2 }); }" + vbCrLf + _ 349 | " private object Method3(object p1, object p2, object p3) { return Method(new object[] { p1, p2, p3 }); }" + vbCrLf + _ 350 | " private object Method4(object p1, object p2, object p3, object p4) { return Method(new object[] { p1, p2, p3, p4 }); }" + vbCrLf + _ 351 | " private object Method5(object p1, object p2, object p3, object p4, object p5) { return Method(new object[] { p1, p2, p3, p4, p5 }); }" + vbCrLf + _ 352 | " private object Method6(object p1, object p2, object p3, object p4, object p5, object p6) { return Method(new object[] { p1, p2, p3, p4, p5, p6 }); }" + vbCrLf + _ 353 | " private object Method7(object p1, object p2, object p3, object p4, object p5, object p6, object p7) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7 }); }" + vbCrLf 354 | code = code + " private object Method8(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8 }); }" + vbCrLf + _ 355 | " private object Method9(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9 }); }" + vbCrLf + _ 356 | " private object Method10(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10 }); }" + vbCrLf + _ 357 | " private object Method11(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11 }); }" + vbCrLf + _ 358 | " private object Method12(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12 }); }" + vbCrLf + _ 359 | " private object Method13(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13 }); }" + vbCrLf + _ 360 | " private object Method14(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14 }); }" + vbCrLf + _ 361 | " private object Method15(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15 }); }" + vbCrLf + _ 362 | " private object Method16(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16 }); }" + vbCrLf + _ 363 | " private object Method17(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16, object p17) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16, p17 }); }" + vbCrLf + _ 364 | " private object Method18(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16, object p17, object p18) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16, p17, p18 }); }" + vbCrLf + _ 365 | " private object Method19(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16, object p17, object p18, object p19) { return Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16, p17, p18, p19 }); }" + vbCrLf + _ 366 | " private void VMethod0() { Method(new object[] { }); }" + vbCrLf + _ 367 | " private void VMethod1(object p1) { Method(new object[] { p1 }); }" + vbCrLf + _ 368 | " private void VMethod2(object p1, object p2) { Method(new object[] { p1, p2 }); }" + vbCrLf + _ 369 | " private void VMethod3(object p1, object p2, object p3) { Method(new object[] { p1, p2, p3 }); }" + vbCrLf + _ 370 | " private void VMethod4(object p1, object p2, object p3, object p4) { Method(new object[] { p1, p2, p3, p4 }); }" + vbCrLf + _ 371 | " private void VMethod5(object p1, object p2, object p3, object p4, object p5) { Method(new object[] { p1, p2, p3, p4, p5 }); }" + vbCrLf + _ 372 | " private void VMethod6(object p1, object p2, object p3, object p4, object p5, object p6) { Method(new object[] { p1, p2, p3, p4, p5, p6 }); }" + vbCrLf + _ 373 | " private void VMethod7(object p1, object p2, object p3, object p4, object p5, object p6, object p7) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7 }); }" + vbCrLf 374 | code = code + " private void VMethod8(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8 }); }" + vbCrLf + _ 375 | " private void VMethod9(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9 }); }" + vbCrLf + _ 376 | " private void VMethod10(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10 }); }" + vbCrLf + _ 377 | " private void VMethod11(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11 }); }" + vbCrLf + _ 378 | " private void VMethod12(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12 }); }" + vbCrLf + _ 379 | " private void VMethod13(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13 }); }" + vbCrLf + _ 380 | " private void VMethod14(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14 }); }" + vbCrLf + _ 381 | " private void VMethod15(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15 }); }" + vbCrLf + _ 382 | " private void VMethod16(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16 }); }" + vbCrLf + _ 383 | " private void VMethod17(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16, object p17) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16, p17 }); }" + vbCrLf + _ 384 | " private void VMethod18(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16, object p17, object p18) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16, p17, p18 }); }" + vbCrLf + _ 385 | " private void VMethod19(object p1, object p2, object p3, object p4, object p5, object p6, object p7, object p8, object p9, object p10, object p11, object p12, object p13, object p14, object p15, object p16, object p17, object p18, object p19) { Method(new object[] { p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16, p17, p18, p19 }); }" + vbCrLf + _ 386 | "}" + vbCrLf + _ 387 | "" + vbCrLf 388 | ' end of class VBVariableDelegateWrapper 389 | 390 | ' class VBManagedSupport 391 | ' provides following methods (with VB-style declaration): 392 | ' Function MyInvoke(mb As MethodBase, ins As Variant, pms() As Variant, isIntPtr() As Variant) As Variant 393 | ' Function MyGetType(obj As Variant) As Type 394 | ' Function MyInvokeMember(targetType As Type, methodName As String, bindingFlags As BindingFlags, obj As Variant, methodArgs() As Variant) As Variant 395 | ' Function MyInvokeInstanceMember(obj As Variant, methodName As String, bindingFlags As BindingFlags, methodArgs() As Variant) As Variant 396 | ' Function MyCreateDelegate(delegateType As Type, obj As Variant, methodName As String) As Delegate 397 | code = code + _ 398 | "[ComVisible(true)]" + vbCrLf + _ 399 | "public class " + rName + " {" + vbCrLf + _ 400 | " public object MyInvoke(MethodBase mb, object ins, object[] pms, object[] isIntPtr) {" + vbCrLf + _ 401 | " object[] newParams = new object[pms.Length];" + vbCrLf + _ 402 | " for (int i = 0; i < pms.Length; ++i) {" + vbCrLf + _ 403 | " if (isIntPtr[i] is bool && (bool)isIntPtr[i]) {" + vbCrLf + _ 404 | " object o = pms[i];" + vbCrLf + _ 405 | " if (o is int) {" + vbCrLf + _ 406 | " newParams[i] = new IntPtr((int)o);" + vbCrLf + _ 407 | " } else if (o is Int64) {" + vbCrLf + _ 408 | " newParams[i] = new IntPtr((Int64)o);" + vbCrLf + _ 409 | " } else {" + vbCrLf + _ 410 | " newParams[i] = (IntPtr)o;" + vbCrLf + _ 411 | " }" + vbCrLf + _ 412 | " } else {" + vbCrLf + _ 413 | " newParams[i] = pms[i];" + vbCrLf + _ 414 | " }" + vbCrLf + _ 415 | " }" + vbCrLf + _ 416 | " return mb.Invoke(ins, newParams);" + vbCrLf + _ 417 | " }" + vbCrLf 418 | code = code + _ 419 | " public Type MyGetType(object obj) {" + vbCrLf + _ 420 | " return obj.GetType();" + vbCrLf + _ 421 | " }" + vbCrLf 422 | code = code + _ 423 | " public object MyInvokeMember(Type targetType, string methodName, BindingFlags bindingFlags, object obj, object[] methodArgs) {" + vbCrLf + _ 424 | " return targetType.InvokeMember(methodName, bindingFlags, null, obj, methodArgs);" + vbCrLf + _ 425 | " }" + vbCrLf 426 | code = code + _ 427 | " public object MyInvokeInstanceMember(object obj, string methodName, object[] methodArgs) {" + vbCrLf + _ 428 | " return obj.GetType().InvokeMember(methodName, BindingFlags.Public | BindingFlags.Instance | BindingFlags.InvokeMethod, null, obj, methodArgs);" + vbCrLf + _ 429 | " }" + vbCrLf 430 | code = code + _ 431 | " public Delegate MyCreateDelegate(Type delegateType, object obj, string methodName) {" + vbCrLf + _ 432 | " return " + rIName + ".CreateDelegate(delegateType, obj, methodName);" + vbCrLf + _ 433 | " }" + vbCrLf 434 | code = code + _ 435 | " public Delegate MyCreateDelegateWithFunction(Type delegateType, object objPtr) {" + vbCrLf + _ 436 | " IntPtr x;" + vbCrLf + _ 437 | " if (objPtr is int) {" + vbCrLf + _ 438 | " x = new IntPtr((int)objPtr);" + vbCrLf + _ 439 | " } else if (objPtr is Int64) {" + vbCrLf + _ 440 | " x = new IntPtr((Int64)objPtr);" + vbCrLf + _ 441 | " } else {" + vbCrLf + _ 442 | " x = (IntPtr)objPtr;" + vbCrLf + _ 443 | " }" + vbCrLf + _ 444 | " return Marshal.GetDelegateForFunctionPointer(x, delegateType);" + vbCrLf + _ 445 | " }" + vbCrLf + _ 446 | "}" + vbCrLf 447 | ' end of class VBManagedSupport 448 | 449 | 'Set asm = domain.Load_2("System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089") 450 | Set asm = ExecuteCSharpCode(domain, code) 451 | Set CreateManagedSupportObject = ToObject(asm.CreateInstance(rName)) 452 | End Function 453 | 454 | '------------------------------------------------------------------------------- 455 | ' Public properties/methods 456 | '------------------------------------------------------------------------------- 457 | 458 | ' Initializes this object. 459 | ' TerminateOnExit: Terminates CLR when Visual Basic application finishes 460 | ' WARNING: When True, you must not Stop debug when breaking. 461 | ' When False, you should not Stop debug without releasing this instance. 462 | ' Version: CLR version to use 463 | Public Sub Initialize(ByVal TerminateOnExit As Boolean, Optional ByVal Version As String = "v4.0.30319") 464 | If Not m_host Is Nothing Then Exit Sub 465 | If TerminateOnExit Then 466 | Dim o As Object 467 | Set o = AddExitHandler(Me, "VBCLRHost") 468 | If Not o Is Me Then 469 | Call Err.Raise(31027, , "Another CLRHost instance is running") 470 | End If 471 | End If 472 | On Error GoTo Handler 473 | Set m_host = CreateCorRuntimeHost(Version) 474 | Call m_host.Start 475 | On Error GoTo Handler2 476 | Call m_host.CreateDomain("VBCLRHostDomain", Nothing, m_domain) 477 | Set m_asmCore = m_domain.Load_2("mscorlib") 478 | Set m_typeObject = m_asmCore.GetType_2("System.Object") 479 | Set m_objManagedSupport = CreateManagedSupportObject(m_domain) 480 | Set m_collTypeCache = New Collection 481 | Exit Sub 482 | Handler2: 483 | Set m_typeObject = Nothing 484 | Set m_asmCore = Nothing 485 | If Not m_domain Is Nothing Then Call m_host.UnloadDomain(m_domain) 486 | Set m_domain = Nothing 487 | Call m_host.Stop 488 | Handler: 489 | Set m_host = Nothing 490 | Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) 491 | End Sub 492 | 493 | ' Terminates the object. 494 | Public Sub Terminate() 495 | Call CleanupImpl 496 | End Sub 497 | 498 | ' (Used by ExitHandler module) 499 | Public Sub OnExit() 500 | Attribute OnExit.VB_MemberFlags = "40" 501 | Call CleanupImpl 502 | End Sub 503 | 504 | ' Converts CLR's object to VB Object 505 | Public Function ToObject(ByVal obj As mscorlib.Object) As Object 506 | Set ToObject = obj 507 | End Function 508 | 509 | ' Converts CLR's object to IEnumerable 510 | Public Function ToEnumerable(ByVal obj As mscorlib.Object) As mscorlib.IEnumerable 511 | Set ToEnumerable = obj 512 | End Function 513 | 514 | ' Gets the actual CorRuntimeHost object 515 | Public Property Get RuntimeHost() As mscoree.CorRuntimeHost 516 | Set RuntimeHost = m_host 517 | End Property 518 | 519 | ' Gets the AppDomain object for CLRHost 520 | Public Property Get AppDomain() As mscorlib.AppDomain 521 | Set AppDomain = m_domain 522 | End Property 523 | 524 | ' Loads the assembly (same as AppDomain.Load_2) 525 | Public Function CLRLoadAssembly(ByVal AssemblyName As String) As mscorlib.Assembly 526 | Set CLRLoadAssembly = m_domain.Load_2(AssemblyName) 527 | End Function 528 | 529 | ' Returns the result of obj.GetType(). 530 | ' Some of objects cannot call obj.GetType() directory; 531 | ' using this method you can retrieve the Type instance of the object. 532 | Public Function CLRGetType(ByVal obj As mscorlib.Object) As mscorlib.Type 533 | Set CLRGetType = m_objManagedSupport.MyGetType(obj) 534 | End Function 535 | 536 | ' Resolves the type name to Type instance 537 | ' This method searches the type from all loaded assemblies. 538 | ' This method also supports the cache system; 539 | ' once the type is resolved, next time this method will return 540 | ' the cached type for the same type (will be faster). 541 | Public Function CLRResolveType(ByVal TypeName As String) As mscorlib.Type 542 | Dim strActualTypeName As String 543 | strActualTypeName = TypeName 544 | Set CLRResolveType = Nothing 545 | On Error Resume Next 546 | Set CLRResolveType = m_collTypeCache.Item(strActualTypeName) 547 | On Error GoTo 0 548 | If Not CLRResolveType Is Nothing Then 549 | Exit Function 550 | End If 551 | 552 | Dim asms() As mscorlib.Assembly 553 | Dim v As Variant, asm As Assembly 554 | Set CLRResolveType = Nothing 555 | asms = m_domain.GetAssemblies() 556 | For Each v In asms 557 | Set asm = v 558 | Set CLRResolveType = asm.GetType_2(strActualTypeName) 559 | If Not CLRResolveType Is Nothing Then 560 | Call m_collTypeCache.Add(CLRResolveType, strActualTypeName) 561 | Exit Function 562 | End If 563 | Next v 564 | End Function 565 | 566 | ' Creates the instance of specified type 567 | Public Function CLRCreateObject(ByVal TypeName As String) As mscorlib.Object 568 | Dim t As mscorlib.Type 569 | Set t = CLRResolveType(TypeName) 570 | If t Is Nothing Then Call Err.Raise(419) 571 | Set CLRCreateObject = t.Assembly.CreateInstance_2(TypeName, False) 572 | End Function 573 | 574 | ' Creates the instance of specified type with constructor parameters 575 | Public Function CLRCreateObjectWithParams(ByVal TypeName As String, ParamArray Arguments() As Variant) As mscorlib.Object 576 | Dim t As mscorlib.Type 577 | Set t = CLRResolveType(TypeName) 578 | If t Is Nothing Then Call Err.Raise(419) 579 | Dim v() As Variant 580 | v = Arguments 581 | Set CLRCreateObjectWithParams = ToObject(t.Assembly).CreateInstance_3(TypeName, False, _ 582 | BindingFlags_Public Or BindingFlags_Instance Or BindingFlags_CreateInstance, _ 583 | Nothing, v, Nothing, Array()) 584 | End Function 585 | 586 | ' Returns the property value of specified name in the object with additional parameters 587 | Public Function CLRPropertyGet(ByVal obj As mscorlib.Object, ByVal PropName As String, ParamArray Arguments() As Variant) As Variant 588 | Dim hr As Long, v() As Variant 589 | v = Arguments 590 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 591 | hr = VariantCopy(CLRPropertyGet, m_objManagedSupport.MyInvokeMember( _ 592 | CLRGetType(obj), _ 593 | PropName, _ 594 | BindingFlags_GetProperty Or BindingFlags_Instance Or BindingFlags_Public, _ 595 | obj, v)) 596 | If hr < 0 Then Call Err.Raise(hr) 597 | End Function 598 | 599 | ' Changes the property value of specified name in the object with additional parameters 600 | Public Sub CLRPropertyPut(ByVal obj As mscorlib.Object, ByVal PropName As String, ByVal Value As Variant, ParamArray Arguments() As Variant) 601 | Dim v() As Variant 602 | Dim lb As Long, ub As Long, c As Long, i As Long, j As Long 603 | lb = LBound(Arguments) 604 | ub = UBound(Arguments) 605 | c = ub - lb + 1 606 | ReDim v(0 To c) 607 | j = lb 608 | Call VariantCopy(v(0), Value) 609 | For i = 1 To c 610 | Call VariantCopy(v(i), Arguments(j)) 611 | j = j + 1 612 | Next i 613 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 614 | Call m_objManagedSupport.MyInvokeMember( _ 615 | CLRGetType(obj), _ 616 | PropName, _ 617 | BindingFlags_SetProperty Or BindingFlags_Instance Or BindingFlags_Public, _ 618 | obj, v) 619 | End Sub 620 | 621 | ' Accessor of CLRPropertyGet for using property-style 622 | Public Property Get CLRProperty(ByVal obj As mscorlib.Object, ByVal PropName As String) As Variant 623 | Call VariantCopy(CLRProperty, CLRPropertyGet(obj, PropName)) 624 | End Property 625 | 626 | ' Accessor of CLRPropertyPut for using property-style 627 | Public Property Let CLRProperty(ByVal obj As mscorlib.Object, ByVal PropName As String, ByVal Value As Variant) 628 | Call CLRPropertyPut(obj, PropName, Value) 629 | End Property 630 | 631 | ' Accessor of CLRPropertyPut for using property-style (with Set) 632 | Public Property Set CLRProperty(ByVal obj As mscorlib.Object, ByVal PropName As String, ByVal Value As Variant) 633 | Call CLRPropertyPut(obj, PropName, Value) 634 | End Property 635 | 636 | ' Calls the instance method 637 | Public Function CLRInvokeMethod(ByVal obj As mscorlib.Object, ByVal MethodName As String, ParamArray Arguments() As Variant) As Variant 638 | Dim v() As Variant 639 | v = Arguments 640 | Dim hr As Long 641 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 642 | hr = VariantCopy(CLRInvokeMethod, m_objManagedSupport.MyInvokeInstanceMember( _ 643 | obj, _ 644 | MethodName, _ 645 | v _ 646 | )) 647 | If hr < 0 Then Call Err.Raise(hr) 648 | End Function 649 | 650 | ' Calls the instance method with specified type. 651 | ' ArgTypesAndArgs must be the following values: 652 | ' index[0, 2, 4, ...]: Type instance(s) 653 | ' index[1, 3, 5, ...]: parameter value(s) 654 | Public Function CLRInvokeMethodWithTypes(ByVal obj As mscorlib.Object, ByVal MethodName As String, ParamArray ArgTypesAndArgs() As Variant) As Variant 655 | Dim ArgTypes() As Variant, Args() As Variant 656 | Dim c As Long, lb As Long, ub As Long, i As Long 657 | lb = LBound(ArgTypesAndArgs) 658 | ub = UBound(ArgTypesAndArgs) 659 | c = ub - lb + 1 660 | If c Mod 2 <> 0 Then 661 | Call Err.Raise(5) 662 | End If 663 | ReDim ArgTypes(0 To (c / 2) - 1), Args(0 To (c / 2) - 1) 664 | Dim j As Long 665 | j = lb 666 | For i = 0 To c - 1 Step 2 667 | If Not IsType(ArgTypesAndArgs(j)) Then Call Err.Raise(5) 668 | Set ArgTypes(i) = ArgTypesAndArgs(j) 669 | Call VariantCopy(Args(i), ArgTypesAndArgs(j + 1)) 670 | j = j + 2 671 | Next i 672 | 673 | Dim cmi As mscorlib.MethodInfo 674 | Set cmi = PickupMethodByParamTypeImpl(CLRGetType(obj), MethodName, BindingFlags_Public Or BindingFlags_Instance, ArgTypes) 675 | If cmi Is Nothing Then Call Err.Raise(438) 676 | 677 | Dim hr As Long 678 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 679 | hr = VariantCopy(CLRInvokeMethodWithTypes, ToObject(cmi).Invoke_3(obj, Args)) 680 | If hr < 0 Then Call Err.Raise(hr) 681 | End Function 682 | 683 | ' Calls the instance method with specified type. 684 | Public Function CLRInvokeMethodWithTypes2(ByVal obj As mscorlib.Object, ByVal MethodName As String, ByRef ArgTypes() As Variant, ParamArray Arguments() As Variant) As Variant 685 | Dim cmi As mscorlib.MethodInfo 686 | Set cmi = PickupMethodByParamTypeImpl(CLRGetType(obj), MethodName, BindingFlags_Public Or BindingFlags_Instance, ArgTypes) 687 | If cmi Is Nothing Then Call Err.Raise(438) 688 | 689 | Dim hr As Long 690 | Dim v() As Variant 691 | v = Arguments 692 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 693 | hr = VariantCopy(CLRInvokeMethodWithTypes2, ToObject(cmi).Invoke_3(obj, v)) 694 | If hr < 0 Then Call Err.Raise(hr) 695 | End Function 696 | 697 | ' Calls the static method 698 | Public Function CLRInvokeStaticMethod(ByVal t As mscorlib.Type, ByVal MethodName As String, ParamArray Arguments() As Variant) As Variant 699 | Dim hr As Long 700 | Dim v() As Variant 701 | v = Arguments 702 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 703 | hr = VariantCopy(CLRInvokeStaticMethod, m_objManagedSupport.MyInvokeMember( _ 704 | t, _ 705 | MethodName, _ 706 | BindingFlags_Public Or BindingFlags_Static Or BindingFlags_InvokeMethod, _ 707 | Nothing, v _ 708 | )) 709 | If hr < 0 Then Call Err.Raise(hr) 710 | End Function 711 | 712 | ' Calls the static method with specified type. 713 | ' ArgTypesAndArgs must be the following values: 714 | ' index[0, 2, 4, ...]: Type instance(s) 715 | ' index[1, 3, 5, ...]: parameter value(s) 716 | Public Function CLRInvokeStaticMethodWithTypes(ByVal t As mscorlib.Type, ByVal MethodName As String, ParamArray ArgTypesAndArgs() As Variant) As Variant 717 | Dim ArgTypes() As Variant, Args() As Variant 718 | Dim c As Long, lb As Long, ub As Long, i As Long 719 | lb = LBound(ArgTypesAndArgs) 720 | ub = UBound(ArgTypesAndArgs) 721 | c = ub - lb + 1 722 | If c Mod 2 <> 0 Then 723 | Call Err.Raise(5) 724 | End If 725 | c = c / 2 726 | ReDim ArgTypes(0 To c - 1), Args(0 To c - 1) 727 | Dim j As Long 728 | j = lb 729 | For i = 0 To c - 1 730 | If Not IsType(ArgTypesAndArgs(j)) Then Call Err.Raise(5) 731 | Set ArgTypes(i) = ArgTypesAndArgs(j) 732 | Call VariantCopy(Args(i), ArgTypesAndArgs(j + 1)) 733 | j = j + 2 734 | Next i 735 | 736 | Dim cmi As mscorlib.MethodInfo 737 | Set cmi = PickupMethodByParamTypeImpl(t, MethodName, BindingFlags_Public Or BindingFlags_Static, ArgTypes) 738 | If cmi Is Nothing Then Call Err.Raise(438) 739 | 740 | Dim hr As Long 741 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 742 | hr = VariantCopy(CLRInvokeStaticMethodWithTypes, ToObject(cmi).Invoke_3(Nothing, Args)) 743 | If hr < 0 Then Call Err.Raise(hr) 744 | End Function 745 | 746 | ' Calls the static method with specified type. 747 | Public Function CLRInvokeStaticMethodWithTypes2(ByVal t As mscorlib.Type, ByVal MethodName As String, ByRef ArgTypes() As Variant, ParamArray Arguments() As Variant) As Variant 748 | Dim cmi As mscorlib.MethodInfo 749 | Set cmi = PickupMethodByParamTypeImpl(t, MethodName, BindingFlags_Public Or BindingFlags_Static, ArgTypes) 750 | If cmi Is Nothing Then Call Err.Raise(438) 751 | 752 | Dim hr As Long, v() As Variant 753 | v = Arguments 754 | ' 「Set」なしで値をコピー(ムーブ)できるように VariantCopy を用いる 755 | hr = VariantCopy(CLRInvokeStaticMethodWithTypes2, ToObject(cmi).Invoke_3(Nothing, v)) 756 | If hr < 0 Then Call Err.Raise(hr) 757 | End Function 758 | 759 | ' Parses the value into actual enum value 760 | Public Function CLRParseEnum(ByVal EnumTypeName As String, ByVal Value As Variant) As Variant 761 | Dim tEnum As mscorlib.Type 762 | Set tEnum = CLRResolveType("System.Enum") 763 | Dim tTargetEnum As mscorlib.Type 764 | Set tTargetEnum = CLRResolveType(EnumTypeName) 765 | If VarType(Value) = vbString Then 766 | CLRParseEnum = CLRInvokeStaticMethod(tEnum, "Parse", tTargetEnum, Value) 767 | Else 768 | CLRParseEnum = CLRInvokeStaticMethod(tEnum, "ToObject", tTargetEnum, CLng(Value)) 769 | End If 770 | End Function 771 | 772 | ' Parses the value into actual enum value with Type instance 773 | Public Function CLRParseEnumByType(ByVal tTargetEnum As mscorlib.Type, ByVal Value As Variant) As mscorlib.Object 774 | Dim tEnum As mscorlib.Type 775 | Set tEnum = CLRResolveType("System.Enum") 776 | If VarType(Value) = vbString Then 777 | Set CLRParseEnumByType = CLRInvokeStaticMethod(tEnum, "Parse", tTargetEnum, Value) 778 | Else 779 | Set CLRParseEnumByType = CLRInvokeStaticMethod(tEnum, "ToObject", tTargetEnum, CLng(Value)) 780 | End If 781 | End Function 782 | 783 | ' Creates the delegate instance which calls the method of specified instance 784 | Public Function CLRCreateDelegate(ByVal typeDelegate As mscorlib.Type, ByVal Target As Object, ByVal MethodName As String) As mscorlib.Delegate 785 | Set CLRCreateDelegate = m_objManagedSupport.MyCreateDelegate(typeDelegate, Target, MethodName) 786 | End Function 787 | 788 | ' Creates the delegate instance which calls the function 789 | ' FuncPtr must be specified with AddressOf operator 790 | ' CAUTION: the signature of the function represented by FuncPtr must match 791 | ' with the specified delegate type; inappropriate parameter types or 792 | ' return type may cause the program crash. 793 | Public Function CLRCreateDelegateWithFunction(ByVal typeDelegate As mscorlib.Type, ByVal FuncPtr As LongPtr) As mscorlib.Delegate 794 | Set CLRCreateDelegateWithFunction = m_objManagedSupport.MyCreateDelegateWithFunction(typeDelegate, FuncPtr) 795 | End Function 796 | --------------------------------------------------------------------------------