Использование ActiveX контролов без регистрации

Здесь можно найти готовые «кирпичики» — части кода, пригодные для построения более крупных проектов, а также решения различных типовых и не очень задач на VB.

Модератор: Brickgroup

The trick
Постоялец
Постоялец
 
Сообщения: 518
Зарегистрирован: 26.06.2010 (Сб) 23:08

Использование ActiveX контролов без регистрации

Сообщение The trick » 04.06.2014 (Ср) 17:51

Разработал модуль с помощью которого можно работать с ActiveX контролами незарегистрированными в реестре, а также реализована поддержка событий. В нем содержится функция ControlsAdd (аналогия метода формы Controls.Add), с помощью которой можно добавлять контролы используя путь к библиотеке и CLSID контрола. Модуль особо не тестировался, поэтому что-то может не заработать, но ActiveX контролы, созданные в VB, а также несколько стандартных библиотек работали нормально. В качестве примера, я создал 2 тестовые библиотеки и главную программу, в которой используются контролы из этих библиотек.

В качестве 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
Вложения
UseUnregActiveXControls.rar
Кирпич, тестовые OCX и пример
(40.89 Кб) Скачиваний: 190
UA6527P

Вернуться в Кирпичный завод

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2

    TopList