В качестве ProgID, нужно указывать любую строку вида xxxx.xxxx (xxx - произвольное число символов). После этого можно уже добавлять используя этот ProgID через стандартный метод
- Код: Выделить всё
Controls.Add (ProgID, Name)
MiscStatus - параметр, отвечающий за создание и отображение объекта (обычно 131473).
Также можно сделать (я не делал) перебор всех коклассов в библиотеке, получение их имен, идентификаторов класса, и уже использовать в качестве ProgID строку вида LibraryName.TypeName, тогда функцию можно упростить и сделать ее почти такой-же как и одноименный метод формы. Работа функции основана на перехвате необходимых функций и создание условий при которых VB "думает" что библиотека зарегистрирована. Для перехвата я использовал свой модуль modTrickHook.bas.
Перехватывая CLSIDFromProgID, возвращаем CLSID нужного нам элемента управления, тем самым VB6 добавляет в коллекцию лицензий наш незарегистрированный класс. Перехватывая CoGetClassObject, получаем объект фабрики классов для создания экземпляров, вручную вызывая функцию DllGetClassObject из библиотеки. Перехват OleRegGetMiscStatus дает нам возможность задать MiscStatus для незарегистрированного элемента, а RegQueryValue получаем пути к библиотеке, библиотеке типов и версию (я использовал 1.00). Далее подменяя LoadRegTypeLibHook на LoadTypeLibEx грузим библиотеку типов не регистрируя ее в реестре (теперь мы можем использовать события). В дополнение идет перехват DllFunctionCall для динамической смены имени библиотеки и вызова DllGetClassObject, а также обнуление адреса функции и hInstance библиотеки, т.к. иначе функция будет вызываться по тому же адресу, а DllFunctionCall больше не вызовется.
PS. На реализацию контролов не нужно обращать внимания, они сделаны в спешке за несклько минут из моего синтезатора, так что годятся только для примера.
- Код: Выделить всё
Option Explicit
' Модуль modTrickUnregControl.bas для поддержки работы с контролами, незарегистрированными в реестре
' © Кривоус Анатолий Анатольевич (The trick), 2014
' Для работы нужен модуль modTrickHook.bas
Public Type GUID
data1 As Long
data2 As Integer
data3 As Integer
data4(7) As Byte
End Type
Public Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszCLSID As Long, CLSID As GUID) As Long
Private Declare Function CLSIDFromProgID Lib "ole32" (ByVal lpszCLSID As Long, CLSID As GUID) As Long
Private Declare Function StringFromGUID2 Lib "ole32" (ByRef lpGUID As GUID, ByVal lpStr As Long, ByVal lSize As Long) As Long
Private Declare Function CoGetClassObject Lib "ole32" (CLSID As GUID, ByVal dwClsContext As Long, ByVal pServerInfo As Long, riid As GUID, ret As IUnknown) As Long
Private Declare Function OleRegGetMiscStatus Lib "ole32" (CLSID As GUID, ByVal dwAspect As Long, pdwStatus As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function IsEqualGUID Lib "ole32" (rguid1 As GUID, rguid2 As GUID) As Boolean
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As Long, ByVal lpValue As Long, lpcbValue As Long) As Long
Private Declare Function LoadRegTypeLib Lib "oleaut32" (rguid As GUID, ByVal wVerMajor As Integer, ByVal wVerMinor As Integer, ByVal lcid As Long, ByVal pptlib As Long) As Long
Private Declare Function LoadTypeLibEx Lib "oleaut32" (ByVal szFile As Long, ByVal regkind As Long, ByVal pptlib As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal count As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function ideDllFunctionCall Lib "vba6" Alias "DllFunctionCall" (ByVal inf As Long) As Long
Private Declare Function exeDllFunctionCall Lib "msvbvm60" Alias "DllFunctionCall" (ByVal inf As Long) As Long
' Библиотека меняется динамически для каждого случая
Private Declare Function DllGetClassObject Lib "*" (CLSID As GUID, iid As GUID, out As IUnknown) As Long
Private Const CO_E_DLLNOTFOUND As Long = &H800401F8
Private Const CO_E_ERRORINDLL As Long = &H800401F9
Private Const REGKIND_NONE As Long = 2
Private Const PAGE_EXECUTE_READWRITE As Long = &H40&
Private Const PAGE_READWRITE As Long = 4&
Dim retCLSID As GUID ' CLSID - класса добавляемого контрола
Dim strCLSID As String ' Строковое (ASCII) представление CLSID
Dim retPath As String ' Путь к библиотеке
Dim convPath As String ' Путь к библиотеке (ASCII)
Dim retMisc As Long ' Параметр определяющий создание и отображение объекта
Dim retProgID As String ' ProgID
Dim init As Boolean ' Инициализирован ли вызов по указателю
Dim Index As Long ' Индекс перехвата первой функции
Dim TlbPath As String ' Путь в реестре для Tlb
Dim VrsPath As String ' Путь в реестре для версии
Dim PrcPath As String ' Путь к библиотеке в реестре
Dim defVersion As String ' Версия библиотеки
Dim hookCount As Long ' Количество перехватов
Dim inIDE As Boolean ' Если в IDE, то TRUE
Dim iDFC As Long ' Индекс перехвата DllFunctionCall
' Функция добавляет контрол на форму (аналог Controls.Add)
' ProgID - любая строка вида xxx.xxx (число символов произвольно, но не меньше 1), которая затем будет
' использоваться для добавления через стандартный Controls.Add
' MiscStatus - одноименный параметр определяющий создание и отображение объекта
Public Function ControlsAdd(path As String, CLSID As GUID, ProgID As String, ByVal MiscStatus As Long, Parent As Form, _
Name As String, Optional Container As Object) As Object
Dim i As Long
On Error GoTo Cancel
hookCount = 0: iDFC = 0
retCLSID = CLSID: retPath = path: retMisc = MiscStatus: retProgID = ProgID
strCLSID = Space(38): StringFromGUID2 CLSID, StrPtr(strCLSID), 39
' Заполняем пути для реестра
TlbPath = StrConv("CLSID\" & strCLSID & "\TypeLib", vbFromUnicode)
VrsPath = StrConv("CLSID\" & strCLSID & "\Version", vbFromUnicode)
PrcPath = StrConv("CLSID\" & strCLSID & "\InprocServer32", vbFromUnicode)
defVersion = StrConv("1.00", vbFromUnicode)
convPath = StrConv(path, vbFromUnicode)
strCLSID = StrConv(strCLSID, vbFromUnicode)
' Перехват функций
hookCount = 4
Index = modTrickHook.Add(modTrickHook.GetFuncAddress("ole32", "CLSIDFromProgID"), AddressOf CLSIDFromProgIDHook, True)
modTrickHook.Add modTrickHook.GetFuncAddress("ole32", "CoGetClassObject"), AddressOf CoGetClassObjectHook, True
modTrickHook.Add modTrickHook.GetFuncAddress("ole32", "OleRegGetMiscStatus"), AddressOf OleRegGetMiscStatusHook, True
modTrickHook.Add modTrickHook.GetFuncAddress("oleaut32", "LoadRegTypeLib"), AddressOf LoadRegTypeLibHook, True
' Добавляем лицензию )
Licenses.Add ProgID
' Добавляем контрол
Set ControlsAdd = Parent.Controls.Add(ProgID, Name, IIf(Container Is Nothing, Parent, Container))
Cancel:
' Снимаем перехваты
For i = Index To Index + hookCount - 1
modTrickHook.Remove Index
Next
If Err.Number Then Err.Raise Err.Number
End Function
' Функция перехвата CLSIDFromProgID
' При передаче нашего ProgID мы обманываем вызывающую сторону, делая вид что в реестре есть запись HKCR\CLSID\ProgID\CLSID
Private Function CLSIDFromProgIDHook(ByVal lpszProgID As Long, out As GUID) As Long
' Узнаем ProgID
If lstrcmpi(lpszProgID, StrPtr(retProgID)) = 0 Then
' Наш ProgID, обманываем
out = retCLSID
Else
' Для других случаев обработка по умолчанию
modTrickHook.HookEnable(Index) = False
CLSIDFromProgIDHook = CLSIDFromProgID(lpszProgID, out)
modTrickHook.HookEnable(Index) = True
End If
End Function
' Функция перехвата CoGetClassObject
' Здесь мы создаем объект (обычно фабрики классов), используя не запись в реестра, а переданные параметры для имени библиотеки
Private Function CoGetClassObjectHook(CLSID As GUID, ByVal dwClsContext As Long, ByVal pServerInfo As Long, riid As GUID, ret As IUnknown) As Long
Dim hLib As Long
Dim lpAddr As Long
' Сравниваем CLSID
If IsEqualGUID(CLSID, retCLSID) Then
' Наш CLSID
Dim vb_vba As String
Dim e As Long
' Проверка в IDE ли?
Debug.Assert TestIDE(inIDE)
' Выбираем библиотеку в зависимости от исполнения
vb_vba = IIf(inIDE, "vba6", "msvbvm60")
' Перехват DllFunctionCall
If iDFC Then
modTrickHook.HookEnable(iDFC) = True
Else
iDFC = modTrickHook.Add(modTrickHook.GetFuncAddress(vb_vba, "DllFunctionCall"), AddressOf DllFunctionCallHook, True)
hookCount = hookCount + 1
End If
On Error GoTo DllError
CoGetClassObjectHook = DllGetClassObject(CLSID, riid, ret)
Exit Function
DllError:
Select Case Err.Number
Case 53: CoGetClassObjectHook = CO_E_DLLNOTFOUND
Case Else: CoGetClassObjectHook = CO_E_ERRORINDLL
End Select
Err.Clear
Else
' Для других случаев обработка по умолчанию
modTrickHook.HookEnable(Index + 1) = False
CoGetClassObjectHook = CoGetClassObject(CLSID, dwClsContext, pServerInfo, riid, ret)
modTrickHook.HookEnable(Index + 1) = True
End If
End Function
' Функция перехвата OleRegGetMiscStatus
' Здесь мы обманываем вызывающую строну, делая вид что в реестре есть запись HKCR\CLSID\MiscStatus и подсовываем ей свой
Private Function OleRegGetMiscStatusHook(CLSID As GUID, ByVal dwAspect As Long, pdwStatus As Long) As Long
If IsEqualGUID(CLSID, retCLSID) Then
' Наш CLSID
pdwStatus = retMisc
' Перехват RegQueryValueA
modTrickHook.Add modTrickHook.GetFuncAddress("advapi32", "RegQueryValueA"), AddressOf RegQueryValueHook, True
hookCount = hookCount + 1
Else
' Для других случаев обработка по умолчанию
modTrickHook.HookEnable(Index + 2) = False
OleRegGetMiscStatusHook = OleRegGetMiscStatus(CLSID, dwAspect, pdwStatus)
modTrickHook.HookEnable(Index + 2) = True
End If
End Function
' Функция перехвата RegQueryValue
' Здесь мы обманываем вызывающую строну, делая вид что в реестре есть записи HKCR\CLSID\(TypeLib, InprocServer32, Version) и подсовываем ей свой
Private Function RegQueryValueHook(ByVal hKey As Long, ByVal lpSubKey As Long, ByVal lpValue As Long, lpcbValue As Long) As Long
' запрос TypleLib
If lstrcmpi(lpSubKey, StrPtr(TlbPath)) = 0 Then
lstrcpy lpValue, StrPtr(strCLSID): lpcbValue = LenB(strCLSID)
' запрос InprocServer32
ElseIf lstrcmpi(lpSubKey, StrPtr(PrcPath)) = 0 Then
lstrcpyn lpValue, StrPtr(convPath), lpcbValue: lpcbValue = LenB(convPath)
' запрос Version
ElseIf lstrcmpi(lpSubKey, StrPtr(VrsPath)) = 0 Then
lstrcpy lpValue, StrPtr(defVersion): lpcbValue = LenB(defVersion)
modTrickHook.HookEnable(Index + 4) = False
' для других случаев обработка по умолчанию
Else
modTrickHook.HookEnable(Index + 4) = False
RegQueryValueHook = RegQueryValue(hKey, lpSubKey, lpValue, lpcbValue)
modTrickHook.HookEnable(Index + 4) = True
End If
End Function
' Функция перехвата LoadRegTypeLib
' Подменяем ее на LoadTypeLibEx и загружаем tlb из файла, не регистрируя ее
Private Function LoadRegTypeLibHook(rguid As GUID, ByVal wVerMajor As Integer, ByVal wVerMinor As Integer, ByVal lcid As Long, ByVal pptlib As Long) As Long
If IsEqualGUID(rguid, retCLSID) Then
LoadRegTypeLibHook = LoadTypeLibEx(StrPtr(retPath), REGKIND_NONE, pptlib)
Else
modTrickHook.HookEnable(Index + 3) = False
LoadRegTypeLibHook = LoadRegTypeLibHook(rguid, wVerMajor, wVerMinor, lcid, pptlib)
modTrickHook.HookEnable(Index + 3) = True
End If
End Function
' Функция перехвата DllFunctionCall
' Идея, такая же как и у Хакера, проверяем имя библиотеки, только мы заменяем имя на нужное нам
Private Function DllFunctionCallHook(ByVal inf As Long) As Long
Dim old As Long
Dim lpStar As Long
Dim lpDat As Long
' Отключаем перехват
modTrickHook.HookEnable(iDFC) = False
' Разрешаем запись в эту страницу
VirtualProtect ByVal inf, 4, PAGE_READWRITE, old
' Сохраняем предыдущее название библиотеки
GetMem4 ByVal inf, lpStar
' Пишем нужное нам
GetMem4 StrPtr(convPath), ByVal inf
' Вызываем оригинальную функцию
If inIDE Then
DllFunctionCallHook = ideDllFunctionCall(inf)
Else: DllFunctionCallHook = exeDllFunctionCall(inf)
End If
' Зануляем хендл библиотеки и адрес функции
GetMem4 ByVal inf + &HC, lpDat
GetMem4 0&, ByVal lpDat + &H4 ' hLib = 0
GetMem4 0&, ByVal lpDat + &H8 ' lpFuncAddr = 0
' Восстанавливаем права доступа
VirtualProtect ByVal inf, 4, old, 0
End Function
Private Function TestIDE(ByRef bvar As Boolean) As Boolean: bvar = True: TestIDE = True: End Function
