This is code I've been working with over the last few days, making sure it works perfectly. It's about as clean as I'm going to get it, so it's time to post it here.
As credits, this work originated from some work by firehacker, and was originally shown to me by The Trick. Therefore, they (particularly firehacker) deserve a great deal of credit in the derivation of this module.
The code below is to be placed into a standard (BAS) module, and this module must have a name of modNameBasedObjectFactory (from the module's properties). You can change this if you like. However, if you do, find this line of code and change it there as well...
To use it is quite simple. Place it in a standard (BAS) module with that name, and then call CreateObjectPrivate. You might call it like this...
This would essentially be identical to...
Notice that it works quite differently in the IDE than it does in an executable. In the IDE, it can rather easily take advantage of the EbExecuteLine API function found in the "vba6.dll". However, this option isn't available in the executable. Therefore, it must find the lpObjectInfo pointer for the project, which is where the work is. Once that's known, the "__vbaNew" function in the msvbvm60.dll can be called to instantiate the object. Just FYI, the msvbvm60.dll is part of the VB6 runtime, and should be present on all later versions of Windows.
The IdeCreateInstance and ExeCreateInstance functions are also declared as Public, but you should have a specific reason to call these. It's probably best to just always use the CreateObjectPrivate function so that the code can correctly sort out which way to do it.
To build a demo, place the code in your modNameBasedObjectFactory named BAS module, throw a class or two (or 10) into your project, and then instantiate it (or them) from a string using CreateObjectPrivate.
I'm not entirely sure who might need this. But the question of reflection has come up in these forums several times before, and I've never seen anyone successfully answer it. So, here it is.
Also, this is innately available in .NET as well as many other languages. I just love making sure that VB6 will do most of what other languages are capable.
Enjoy,
Elroy
As credits, this work originated from some work by firehacker, and was originally shown to me by The Trick. Therefore, they (particularly firehacker) deserve a great deal of credit in the derivation of this module.
The code below is to be placed into a standard (BAS) module, and this module must have a name of modNameBasedObjectFactory (from the module's properties). You can change this if you like. However, if you do, find this line of code and change it there as well...
Code:
Const MeModule = "modNameBasedObjectFactory"Code:
Dim cls As Class1
Set cls = CreateObjectPrivate("Class1")Code:
Dim cls As Class1
Set cls = New Class1Notice that it works quite differently in the IDE than it does in an executable. In the IDE, it can rather easily take advantage of the EbExecuteLine API function found in the "vba6.dll". However, this option isn't available in the executable. Therefore, it must find the lpObjectInfo pointer for the project, which is where the work is. Once that's known, the "__vbaNew" function in the msvbvm60.dll can be called to instantiate the object. Just FYI, the msvbvm60.dll is part of the VB6 runtime, and should be present on all later versions of Windows.
The IdeCreateInstance and ExeCreateInstance functions are also declared as Public, but you should have a specific reason to call these. It's probably best to just always use the CreateObjectPrivate function so that the code can correctly sort out which way to do it.
To build a demo, place the code in your modNameBasedObjectFactory named BAS module, throw a class or two (or 10) into your project, and then instantiate it (or them) from a string using CreateObjectPrivate.
Code:
Option Explicit
'
Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal i1 As Long, ByVal i2 As Long, ByVal fCheckOnly As Long) As Long
'
Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal s1 As String, ByVal s2 As Long) As Long
Private Declare Function ExeNew Lib "msvbvm60" Alias "__vbaNew" (lpObjectInfo As Any) As IUnknown
Private Declare Function ArrayPtr Lib "msvbvm60" Alias "VarPtr" (ary() As Any) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal lpAddress As Long, dst As Any)
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal lpAddress As Long, ByVal nv As Long)
'
Private Type EXEPROJECTINFO
Signature As Long
RuntimeVersion As Integer
BaseLanguageDll(0 To 13) As Byte
ExtLanguageDll(0 To 13) As Byte
RuntimeRevision As Integer
BaseLangiageDllLCID As Long
ExtLanguageDllLCID As Long
lpSubMain As Long
lpProjectData As Long
' < There are other fields, but not declared, not needed. >
End Type
'
Private Type ProjectData
Version As Long
lpModuleDescriptorsTableHeader As Long
' < There are other fields, but not declared, not needed. >
End Type
'
Private Type MODDESCRTBL_HEADER
Reserved0 As Long
lpProjectObject As Long
lpProjectExtInfo As Long
Reserved1 As Long
Reserved2 As Long
lpProjectData As Long
guid(0 To 15) As Byte
Reserved3 As Integer
TotalModuleCount As Integer
CompiledModuleCount As Integer
UsedModuleCount As Integer
lpFirstDescriptor As Long
' < There are other fields, but not declared, not needed. >
End Type
'
Private Enum MODFLAGS
mfBasic = 1
mfNonStatic = 2
mfUserControl = &H42000
End Enum
'
Private Type MODDESCRTBL_ENTRY
lpObjectInfo As Long
FullBits As Long
Placeholder0(0 To 15) As Byte
lpszName As Long
MethodsCount As Long
lpMethodNamesArray As Long
Placeholder1 As Long
ModuleType As MODFLAGS
Placeholder2 As Long
End Type
'
Private Type SafeArrayOrigType
ArrayName As String
pvDataOrig As Long
cElementsOrig As Long
End Type
'
Private SafeArrayOrig() As SafeArrayOrigType
Private SafeArrayOrigCount As Long
'
Public Function CreateObjectPrivate(ByVal Class As String) As IUnknown
'
' When you work in the compiled form and the different mechanisms will be used by the IDE.
If InIDE Then
Set CreateObjectPrivate = IdeCreateInstance(Class)
Else
Set CreateObjectPrivate = ExeCreateInstance(Class)
End If
End Function
Public Function IdeCreateInstance(ByVal Class As String) As IUnknown
' Only for IDE.
'
If Not InIDE Then
MsgBox "This only works while in the IDE."
Error 5
Exit Function
End If
'
' If the module this is in is renamed, it MUST be changed here as well.
Const MeModule = "modNameBasedObjectFactory"
'
EbExecuteLine StrPtr(MeModule & ".OneCellQueue New " & Class), 0, 0, 0
'
Set IdeCreateInstance = OneCellQueue(Nothing)
If IdeCreateInstance Is Nothing Then
Err.Raise 8, , "Specified class '" + Class + "' is not defined."
Exit Function
End If
End Function
Private Function OneCellQueue(ByVal refIn As IUnknown) As IUnknown
' Returns what was "previously" passed in as refIn,
' and then stores the current refIn for return next time.
'
Static o As IUnknown
'
Set OneCellQueue = o
Set o = refIn
End Function
Public Function ExeCreateInstance(ByVal Class As String) As IUnknown
' Only for Executable.
'
Dim lpObjectInfo As Long
'
If InIDE Then
MsgBox "This does not work while in the IDE."
Error 5
Exit Function
End If
'
' Get the address of a block of information about the class.
' And then create an instance of this class.
' If a class is not found, generated an error.
'
If Not GetOiOfClass(Class, lpObjectInfo) Then
Err.Raise 8, , "Specified class '" + Class + "' is not defined."
Exit Function
End If
'
Set ExeCreateInstance = ExeNew(ByVal lpObjectInfo)
End Function
Private Function GetOiOfClass(ByVal Class As String, lpObjInfo As Long) As Boolean
' Only for Executable.
'
' lpObjInfo is a returned argument.
' Function returns true if successful.
'
Dim Modules() As MODDESCRTBL_ENTRY
Dim i As Long
'
ReDim Modules(0)
LoadDescriptorsTable Modules
'
' We are looking for a descriptor corresponding to the specified class.
For i = LBound(Modules) To UBound(Modules)
With Modules(i)
If lstrcmpi(Class, .lpszName) = 0 And CBool(.ModuleType And mfNonStatic) And Not CBool(.ModuleType And 0) Then
lpObjInfo = .lpObjectInfo
GetOiOfClass = True
Exit For
End If
End With
Next i
'
SafeArrayUnMap ArrayPtr(Modules), "Modules"
End Function
Private Sub LoadDescriptorsTable(Modules() As MODDESCRTBL_ENTRY)
' Only for Executable.
'
Dim lpEPI As Long
Dim EPI(0) As EXEPROJECTINFO
Dim ProjectData(0) As ProjectData
Dim ModDescrTblHdr(0) As MODDESCRTBL_HEADER
'
' This procedure is called only once for the project.
' Get the address of the EPI.
'
If Not FindEpiSimple(lpEPI) Then
Err.Raise 17, , "Failed to locate EXEPROJECTINFO structure in process module image."
Exit Sub
End If
'
' From EPI find location PROJECTDATA, from PROJECTDATA obtain location
' of Table header tags, the title tags, and obtain the number of address sequence.
'
SafeArrayMap ArrayPtr(EPI), lpEPI, "EPI"
SafeArrayMap ArrayPtr(ProjectData), EPI(0).lpProjectData, "ProjectData"
SafeArrayUnMap ArrayPtr(EPI), "EPI"
SafeArrayMap ArrayPtr(ModDescrTblHdr), ProjectData(0).lpModuleDescriptorsTableHeader, "ModDescrTblHdr"
SafeArrayUnMap ArrayPtr(ProjectData), "ProjectData"
' This dt() is unmapped elsewhere.
SafeArrayMap ArrayPtr(Modules), ModDescrTblHdr(0).lpFirstDescriptor, "Modules", ModDescrTblHdr(0).TotalModuleCount
SafeArrayUnMap ArrayPtr(ModDescrTblHdr), "ModDescrTblHdr"
End Sub
Private Function FindEpiSimple(ByRef lpEPI As Long) As Boolean
' Only for Executable.
'
Dim DWords() As Long ' Must be dynamic.
Dim PotentionalEPI(0) As EXEPROJECTINFO
Dim PotentionalPD(0) As ProjectData
Dim i As Long
'
Const EPI_Signature As Long = &H21354256 ' "VB5/6!"
Const PD_Version As Long = &H1F4
'
' We are trying to get a pointer to a structure EXEPROJECTINFO. The address is not stored anywhere.
' Therefore the only way to find the structure is to find its signature.
'
' Current research implementation simply disgusting: it is looking for signatures from the
' very beginning of the image, including those places where it can not be known. And find out
' behind the border of the image, if you find a signature within the virtual image failed,
' this will likely result in AV-exclusion. But its (implementation) is compact.
'
' Basically, this is searching a memory image of the executable's base-code.
'
ReDim DWords(0)
SafeArrayMap ArrayPtr(DWords), App.hInstance, "DWords"
Do
If DWords(i) = EPI_Signature Then
SafeArrayMap ArrayPtr(PotentionalEPI), VarPtr(DWords(i)), "PotentionalEPI"
SafeArrayMap ArrayPtr(PotentionalPD), PotentionalEPI(0).lpProjectData, "PotentionalPD"
If PotentionalPD(0).Version = PD_Version Then
lpEPI = VarPtr(DWords(i))
FindEpiSimple = True
End If
SafeArrayUnMap ArrayPtr(PotentionalPD), "PotentionalPD"
SafeArrayUnMap ArrayPtr(PotentionalEPI), "PotentionalEPI"
If FindEpiSimple Then Exit Do
End If
i = i + 1
Loop
SafeArrayUnMap ArrayPtr(DWords), "DWords"
End Function
Private Sub SafeArrayMap(ByVal ppSA As Long, ByVal pMemory As Long, sArrayName As String, Optional ByVal NewSize As Long = -1)
'
' It's important that the initial array be precisely a one element (zero based) pre-dimensioned array.
' It can be any array type you like. Be careful to not Redim or Erase it before SafeArrayUnMap is called.
'
Dim pSA As Long
Dim pMemoryOrig As Long
Dim OrigSize As Long
'
GetMem4 ppSA, pSA
'
GetMem4 pSA + 12, pMemoryOrig
GetMem4 pSA + 16, OrigSize
'
ReDim Preserve SafeArrayOrig(SafeArrayOrigCount)
SafeArrayOrig(SafeArrayOrigCount).ArrayName = sArrayName
SafeArrayOrig(SafeArrayOrigCount).pvDataOrig = pMemoryOrig
SafeArrayOrig(SafeArrayOrigCount).cElementsOrig = OrigSize
SafeArrayOrigCount = SafeArrayOrigCount + 1
'
PutMem4 pSA + 12, ByVal pMemory ' Point to different data.
PutMem4 pSA + 16, ByVal NewSize ' Change the size.
End Sub
Private Sub SafeArrayUnMap(ByVal ppSA As Long, sArrayName As String)
Dim pSA As Long
Dim i As Long
Dim j As Long
Dim pMemoryOrig As Long
Dim OrigSize As Long
'
' This MUST be found. No error checking.
For i = 0 To SafeArrayOrigCount - 1
If SafeArrayOrig(i).ArrayName = sArrayName Then
pMemoryOrig = SafeArrayOrig(i).pvDataOrig
OrigSize = SafeArrayOrig(i).cElementsOrig
If SafeArrayOrigCount = 1 Then
Erase SafeArrayOrig
Else
For j = i + 1 To SafeArrayOrigCount - 1 ' Won't run if last one.
SafeArrayOrig(j - 1) = SafeArrayOrig(j)
Next j
ReDim Preserve SafeArrayOrig(SafeArrayOrigCount - 2) ' Both the one we're deleting, and zero based.
End If
SafeArrayOrigCount = SafeArrayOrigCount - 1
Exit For
End If
Next i
'
GetMem4 ppSA, pSA
PutMem4 pSA + 12, ByVal pMemoryOrig
PutMem4 pSA + 16, ByVal OrigSize
End Sub
Private Function InIDE() As Boolean
On Error GoTo InTheIDE
Debug.Print 1 / 0
Exit Function
InTheIDE:
InIDE = True
End Function
Also, this is innately available in .NET as well as many other languages. I just love making sure that VB6 will do most of what other languages are capable.
Enjoy,
Elroy