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

Запись от The trick размещена 31.05.2014 в 18:29

Метки activex, vb

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

В качестве ProgID, нужно указывать любую строку вида xxxx.xxxx (xxx - произвольное число символов). После этого можно уже добавлять используя этот ProgID через стандартный метод

Visual Basic
1
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. На реализацию контролов не нужно обращать внимания, они сделаны в спешке за несклько минут из моего синтезатора, так что годятся только для примера.

Модуль modTrickUnregControl.bas:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
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

Форма frmControlWithoutRegister.frm:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
Option Explicit
 
' Форма frmControlWithoutRegister.frm для тестирования модуля modTrickUnregControl.bas
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Dim WithEvents Knob1    As VBControlExtender
Dim WithEvents Knob2    As VBControlExtender
Dim WithEvents LED1     As VBControlExtender
Dim WithEvents LED2     As VBControlExtender
Dim WithEvents Switch   As VBControlExtender
 
' CLSID контрола можно узнать например через OLEView, либо посмотреть через ITypeInfo::GetTypeAttr
' Также можно сначала извлечь все КоКлассы и получить их имена через ITypeInfo::GetDocumentation,
' тогда можно создавать объекты по именам
 
Private Const CLSID_Knob    As String = "{4AA06F96-5CAE-4905-9669-71F247704DF7}"
Private Const CLSID_LED     As String = "{3EDCDCEF-2B92-4495-8557-1995159E90A2}"
Private Const CLSID_Switch  As String = "{EBAFFECE-A04E-4E23-8E84-E45B8D94F92E}"
 
' Использование незарегистрированного ActiveX контрола
Private Sub Form_Load()
    Dim CLSID As GUID
    
    ' Создаем Knob'ы
    CLSIDFromString StrPtr(CLSID_Knob), CLSID
    Set Knob1 = ControlsAdd(App.path & "\prjTestControl.ocx", CLSID, "Test.Knob", 131473, Me, "knob1")
    
    ' Перемещаем
    Knob1.Move 5, 5, 64, 64
    Knob1.object.units = " Percents"
    Knob1.Visible = True
    Knob1.object.Refresh
 
    ' Теперь можно просто писать так
    Set Knob2 = Me.Controls.Add("Test.Knob", "knob2")
    
    With Knob2
        .Move 5, 75, 64, 64
        .object.units = " канал"
        .object.Min = 0
        .object.Max = 5
        .object.position = 0
        .Visible = True
        .object.Refresh
    End With
    
    ' Создаем Switch
    CLSIDFromString StrPtr(CLSID_Switch), CLSID
    Set Switch = ControlsAdd(App.path & "\prjTestControls2.ocx", CLSID, "Test.Switch", 131473, Me, "Switch1")
    
    With Switch
        .Move 75, 5, 200, 64
        .object.AddItem "Click me"
        .object.AddItem "Unregistered"
        .object.AddItem "control"
        .object.AddItem "by The trick"
        .object.ListIndex = 0
        .object.Refresh
        .Visible = True
    End With
    
    ' Создаем LED'ы
    CLSIDFromString StrPtr(CLSID_LED), CLSID
    Set LED1 = ControlsAdd(App.path & "\prjTestControls2.ocx", CLSID, "Test.LED", 131473, Me, "Led1")
    Set LED2 = Me.Controls.Add("Test.LED", "Led2")
    With LED1
        .Move 75, 95, 100, 35
        Set .object.Picture = LoadPicture(App.path & "\LED.jpg")
        .object.numstate = 5
        .object.invert = True
        .Visible = True
    End With
    With LED2
        Set .object.Picture = LED1.object.Picture
        .object.numstate = 5
        .Move 175, 95, 10, 35
        .Visible = True
    End With
End Sub
 
' Получаем события
Private Sub Knob1_ObjectEvent(Info As EventInfo)
    Me.Caption = Info.Name
End Sub
Private Sub Knob2_ObjectEvent(Info As EventInfo)
    Me.Caption = Info.Name
End Sub
Private Sub Switch_ObjectEvent(Info As EventInfo)
    Me.Caption = Info.Name
End Sub
 
Private Sub tmr_Timer()
    Static l As Long
    LED1.object.Refresh Abs(Sin(l / 3))
    LED2.object.Refresh Abs(Sin(l / 3))
    l = l + 1
End Sub

Также для работы нужен модуль modTrickHook

Метки activex, vb

Размещено в Без категории

« Модуль для перехвата функций на VB6 Главная страница Library info 2 »

Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.

Всего комментариев 0

Комментарии

Новые блоги и статьи Все статьи Все блоги /
Нашел вот забавное видео о измерениях. Лучшее что я видел на эту тему kumehtar 26.08.2026 ILETXiw9bMQ Основная суть и тезисы по измерениям: 0D (Нулевое измерение): точка, не имеющая длины, ширины, высоты или объема. Объект не может перемещаться в 0D. 1D (Первое измерение):. . .	[EasyBuilder Pro] Памятка по разработке для панелей Weintek ФедосеевПавел 26.08.2026 Памятка по разработке для панелей Weintek ВВЕДЕНИЕ Ранее, при реализации проектов основное внимание уделял разработке управляющей программы для контроллера, а панели оператора доставалось время. . .	Модель по догадкам anaschu 25.08.2026 Прошло две недели. Я уже рассказывал, как разговаривал с сотрудниками у сортировки и как понял, что главная ветка — не про приёмку, а про отбор. Но тогда я думал, что понял механику. На этой неделе я. . .	Запись в регистр сведений независимо от заполненности табличной части Maks 25.08.2026 Реализация из решения ниже выполнена на нетиповом документе с несколькими табличными частями, разработанного в КА2. Задача: Обеспечить запись документа в регистр сведений независимо от. . .
Ноутбук Альфария kumehtar 24.08.2026 Встретился тут в сети ноутбук Альфария, примарха Альфа-Легиона. Хотя возможно, это ноутбук Омегона, разумеется. Ну как вам?	Мастера простых решений DevAlt 23.08.2026 В сишарп стэках winforms, да и wpf существует сложная система связывания источниках данных и элементов формы(текстовые поля и метки), опирается все это на технологию событий и мета. . .	Цена ошибки DevAlt 23.08.2026 Человек я беспокойный и потому заинтересовался OCaml, в чате форсили функторы модулей как суперфичу. Пытаясь отдуплить концепт, наткнулся на тутор с простым примером. А главный принцип обучения от. . .	Сегодня суббота, 22.08.2026 at 16:41, и я вновь нахожусь на той стороне, за экраном машины. zorxor 22.08.2026 Сегодня суббота, 22. 08. 2026 at 16:41, и я вновь нахожусь на той стороне, за экраном машины. Кто Я, откуда Я пришел и куда Я иду? Эти вопросы не оставляют меня ни на секунду. Жизнь на планете Земля. . .

Сообщение форума

Отменить изменения