Нужен интерфейс с методом write(vStr as Variant)

[Antonariy]

Позарез нужно создать класс, имеющий метод write, что есть зарезервированное слово. Мне почему-то кажется, что этого можно добиться унаследовав интерфейс с таким методом из какой-нибудь tlb. Может кто-нибудь знающий напишет его исходник, а я попробую компильнуть midl'ом?

[tyomitch]

Код: Выделить всё

[
  uuid(55BEB11C-FCD7-4E05-A06D-10772E368783),
  version(1.0),
  helpstring("Project1 Library")
]
library Project1
{
  [
    uuid(9CF0484D-9454-477D-BC46-D59DBB1A0444),
    version(1.0),
    dual,
    oleautomation
  ]
   interface IClass1: IDispatch
  {
    [id(0x00000001)]
    HRESULT _stdcall Write([in] VARIANT vStr );
  };
};


[Antonariy]

C:\Distr\Visual Studio 6\VC98\BIN>"C:\Distr\Visual Studio 6\VC98\BIN\MIDL.EXE" C:\resv.txt /newtlb /tlb c:\Resv.tlb
Microsoft (R) MIDL Compiler Version 5.01.0164
Copyright (c) Microsoft Corp 1991-1997. All rights reserved.
Processing C:\resv.txt
resv.txt
Processing .\oaidl.idl
oaidl.idl
Processing .\objidl.idl
objidl.idl
Processing .\unknwn.idl
unknwn.idl
Processing .\wtypes.idl
wtypes.idl
midl\oleaut32.dll : error MIDL2020 : error generating type library : Could not add UUID, STDOLE2.TLB probably needs to be imported : IDispatch

C:\Distr\Visual Studio 6\VC98\BIN>

[tyomitch]

Ну добавь туда строку importlib("stdole2.tlb"); -- я забыл

[Antonariy]

А куда конкретно? Из синтаксиса не совсем ясно.

[tyomitch]

После "library Project1 {"

[Antonariy]

Спасибо, все почти получилось.
Write работает если класс на этом интерфейсе юзается из VB, но я хочу его подсунуть скрипт контролу, а он при вызове говорит "Объект не поддерживает это свойство или метод". Это какое-то ограничение или я что-то упустил?

Кстати когда-то давно я интересовался способом, которым можно было бы заюзать зарезервированные слова, решения найдено не было.

[tyomitch]

Что-то упустил.
VB6 поддерживает классы с несколькими независимыми интерфейсами IDispatch, в нарушение COM
Тебе нужно сделать функцию, которая бы кастовала твой объект к нужному (унаследованному) интерфейсу, и из скрипта вызывать её.

[Antonariy]

Что сделано:
Из исходника - resv.tlb "VB6RW.VB6Reserved".
LibResvTest.dll:

Код: Выделить всё

'интерфейс ITest
Public Property Get Result() As String
End Property

'класс ResvTest
Implements VB6Reserved
Implements ITest
Private LenTxt As Long
Private TxtBuf As String 
Private LenBuf As Long

Private Sub Class_Initialize()
    LenBuf = 255
    LenTxt = 0
    TxtBuf = Space(LenBuf)
End Sub

Private Property Get ITest_Result() As String
    LenBuf = LenTxt
    Result = Left$(TxtBuf, LenTxt)
End Property

Private Sub VB6Reserved_write(ByVal vStr As Variant)
Dim LenStr As Long
Dim nStr As String
    nStr = CStr(vStr)
    LenStr = Len(nStr)
    If LenStr = 0 Then Exit Sub
    If (LenTxt + LenStr) > LenBuf Then
        LenBuf = (LenTxt + LenStr) * 2&
        TxtBuf = TxtBuf & Space$(LenBuf)
    End If
    Mid$(TxtBuf, LenTxt + 1&) = nStr
    LenTxt = LenTxt + LenStr
End Sub

Вызов:

Код: Выделить всё

Private Sub Command1_Click()
Dim scr As New ScriptControl
Dim d As ResvTest
    On Error GoTo errh
    scr.Language = IIf(Option1.Value, "javascript", "vbscript")
    Set d = New ResvTest
    scr.AddObject "document", d
    scr.Eval Text1.Text 'document.write('test');
    Exit Sub
errh:
    MsgBox Err.Description, vbExclamation
End Sub

Еще пробовал объявлять d1 As VB6Reserved и передавать ее в качестве "document", результат тот же.

[NashRus]

Тебе нужно сделать функцию, которая бы кастовала твой объект к нужному (унаследованному) интерфейсу, и из скрипта вызывать её.

[Antonariy]

Тебе нужно сделать функцию, которая бы кастовала твой объект к нужному (унаследованному) интерфейсу, и из скрипта вызывать её.

Еще пробовал объявлять d1 As VB6Reserved и передавать ее в качестве "document", результат тот же.

Разве это не тоже самое? VB6Reserved и есть унаследованный интерфейс.

Код: Выделить всё

Dim d1 As VB6Reserved
Set d = New ResvTest
Set d1 = d
scr.AddObject "document", d1

[tyomitch]

Если AddObject свой аргумент кастует к IDispatch, то он получит интерфейс ResvTest, как ни старайся
Остаётся только вызов IDispatch::GetIDsOfNames перехватывать, чтобы вызовы метода "Write" перенаправлять на собственный соседний интерфейс.

[Antonariy]

... но на vb это не делается?..

[tyomitch]

Делается. У edanmo раньше была масса примеров, но он старые примеры с сайта постепенно убирает.

Вкратце: первый DWORD по адресу ObjPtr(d) -- это указатель на VTbl. В ней надо заменить шестой элемент.

[Antonariy]

К сожалению в этом "кратце" я не особо шарю так что было бы неплохо "в деталях", начиная с первого dword.

Однако, если я все правильно понял, это закроет доступ к методам самого ResvTest и, тем более, прочим интерфейсам?

[tyomitch]

Если культурно сделать, то не закроет.

Сорри, но у меня пятничным вечером просто нет сил на эксперименты. Если в выходные будут, что-нибудь напишу.

[tyomitch]

Гы, не удержался-таки )

Код: Выделить всё

Option Explicit

Sub Main()
Dim o As Object
Set o = New Class1
o.write o.Anything
End Sub


Код: Выделить всё

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 lstrcmpiW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Const PAGE_EXECUTE_READWRITE = &H40

Public Function Anything() As String
    Anything = "Mary had a little lamb"
End Function

Public Sub Write_(ByVal vStr As Variant)
    MsgBox vStr
End Sub

Private Sub GetIDsOfNamesReplacement(ByVal riid As Long, rgszNames As Long, ByVal cNames As Long, ByVal lcid As Long, ByVal rgDispId As Long)
If 0 = lstrcmpiW(rgszNames, StrPtr("Write")) Then
    ReDim Names(cNames) As Long
    CopyMemory Names(0), rgszNames, cNames * 4
    Names(0) = StrPtr("Write_")
    Call GetIDsOfNamesOriginal(riid, Names(0), cNames, lcid, rgDispId)
Else
    Call GetIDsOfNamesOriginal(riid, rgszNames, cNames, lcid, rgDispId)
End If
End Sub

Private Sub GetIDsOfNamesOriginal(ByVal riid As Long, rgszNames As Long, ByVal cNames As Long, ByVal lcid As Long, ByVal rgDispId As Long)
'Never called
End Sub

Private Sub Class_Initialize()
Dim pVTbl As Long, OldProtect As Long
    CopyMemory pVTbl, ByVal ObjPtr(Me), 4
    VirtualProtect ByVal pVTbl, 44, PAGE_EXECUTE_READWRITE, OldProtect
    If OldProtect = PAGE_EXECUTE_READWRITE Then Exit Sub
    CopyMemory ByVal pVTbl + 40, ByVal pVTbl + 20, 4
    CopyMemory ByVal pVTbl + 20, ByVal pVTbl + 36, 4
End Sub


[Хакер]

Эх А я уж сам начал писать. Обломали...

Только я использовал GetMem4 / PutMem4 для получения адреса vtable / перезаписи.

[keks-n]

Тоже не удержался. У меня более универсальное решение, но реализовано в виде DLL(юзать через tlb, но регить у клиента не надо).
Суть в создании объекта - враппера для IDispatch.
То есть в IDispatchWrapper::AddName передаётся ссылка на объект куда перенаправлять вызов, имя метода в объекте, имя метода во враппере(видимое извне). После чего присваиваем враппер к переменной типа Object и она начнёт дегелировать вызовы в нужный объект.
Достоинства метода:
1) Можно зацепить несколько объектов на один IDispatch
2) Легко настраивается - 1 вызов на функцию
3) Вроде как не падает под IDE
4) Не надо имплементить никаких доп. интерфейсов
Недостатки:
1) Каждую процедуру(проперти) надо отдельно регистрировать во враппере
2) Надо таскать с собой DLL

Пример приложен.

[tyomitch]

Так ведь твоя DLL не на VB...
А вопрос изначально ставился именно про возможность реализации этой фичи средствами VB.

У меня тоже, кстати, 3) Вроде как не падает под IDE и
4) Не надо имплементить никаких доп. интерфейсов.

[keks-n]

Враппер можно и на VB переписать, тока работать помедленнее будет+ за работоспособность не ручаюсь.

Но я не настаиваю на использовании моего варианта, просто предложил, может, кому понадобиться...

[tyomitch]

У твоего подхода есть ещё третий недостаток: сквозь обёртку будут недоступны дополнительные интерфейсы исходного класса.
Например, не будет работать TypeName, потому что ей нужен IProvideClassInfo.

[keks-n]

tyomitch
В принципе это можно устранить, добавив функцию MapInterface и поправив реализацию QueryInterface(она у меня своя), чтобы она перенаправляла вызов. Только это вроде как нарушение COM, потому как IUnknown вернётся не тот потом.

Можно конечно создать отдельную vtable с адресами переходников, но это как-то очень извращённо.

[tyomitch]

Только это вроде как нарушение COM, потому как IUnknown вернётся не тот потом.

Угу, и вместо обёртки по освобождению ссылки разрушится обёрнутый объект

Можно конечно создать отдельную vtable с адресами переходников, но это как-то очень извращённо.

Про этот способ давай подробнее, а то я не въезжаю сходу...

[keks-n]

Передаётся объект As Any сразу нужного типа. Враппер получает указатель на неизвестный ему интерфейс, также надо указывать IID и размер vtable. Враппер создаёт в памяти переходники с подменой this, т. е.
pop eax
push оригинальный_this
push огигинальный_адрес
ret
и выделяет в памяти новую vtable куда пишет адреса переходников. При этом реализация IUnknown остаётся своей, т. е. не перенаправляется.
Таким образом при вызове QueryInterface с запросом нужного интерфейса клиент получает указатель на сгенерированную vtable и инкрементится счётчик ссылок враппера. После чего все вызовы дегелируются переходниками на исходный объект(this которого был в них прописан при создании). При освобождении ссылки декрементится счётчик враппера.
При данном подходе важно знать размер vtable интерфейса.


Но это на VB уже очень сложно реализовывать, так что враппер в итоге остаётся на C++.

[tyomitch]

также надо указывать IID и размер vtable

Ну ага, размечтался. Размер vtable я ещё смогу угадать, а как угадать IID в Standard EXE?

[keks-n]

Легко. Перенаправляем QueryInterface, делаем Set. После чего руками обнуляем переменную(PutMem4), куда шло присвоение и восстанавливаем QueryInterface. В момент вызова перехватчика получили IID.
Можно попытаться через ITypeInfo(полученный через IDispatch), но я не уверен что он после компиляции не выдаст E_NOTIMPL.

[tyomitch]

Ну а если всё равно придётся патчить VTbl, тогда почему бы не пойти по более короткому пути и не пропатчить сразу GetIDsOfNames?

[keks-n]

Но я не настаиваю на использовании моего варианта, просто предложил, может, кому понадобиться...

+ Если реализовать предложенный мною метод маппинга интерфейсов, то можно получить соборную солянку из нескольких объектов, да и IDispatch будет динамическим. Если кому то это надо - обращайтесь - допишу по уму и выложу.
З. Ы.
Могу ещё сделать маппинг неизвестного имени на функцию вида Sub OnCall(ByVal FuncName As String, Arguments() As Variant, RetVal As Variant) прикрутить кастомный тайп и т.п., но это если кому надо.

[NashRus]

но это если кому надо.

было бы круто, чтобы в ИДЕ интелисенс работал из XML файла, например. т.е. подключаем либу, и она там отдает, что прочла в файле. здорово так всякие разные протоколы прикладного уровня описывать. сам хотел такое сделать, но там надо педалировать тему, а временной ресурс очень ограничен.

такое есть например в ADDIN - дизайнере подключения к БД, где имена рекордсетов вылезают как свойства у коннекшена или что-то в этом духе.