I love VB! (COM/ActiveX как реализовать события?)

[Jack Ferre]

Давно пытаюсь перевести труд alexcon314@Flasher.ru «Пишем свою оболочку для FP под Windows», но застрял на первой статье. Перечитал 100500 форумов. Подобных вопросов мало, но есть. А вот ответы на них всегда сводятся к "Can't in VB"

Сегодня таки перевел. Всё оказалось намного проще, чем на С++ (за это и название темы)

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

Call AtlAxWinInit
hwnd = CreateWindowEx(0, "AtlAxWin", FlashProgID, WS_POPUP Or WS_VISIBLE, 0, 0, 400, 300, 0, 0, 0, 0)
Call AtlAxGetControl(hwnd, SWF)

Пример использования:

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

SWF.Movie = "D:\path\file.swf"
SWF.SetVariable "VB.sInput", "Test Data String 1234567890"

Работает этот код прекрасно. VB делает всю грязную работу IUnknown > IDispatch > Invoke.
Остается реализовать события, но как я не знаю.

[Jack Ferre]

Попробывал создать точку соединения с помощью Atl. Cамописный API:

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

Private Declare Function AtlAdvise Lib "atl.dll" (ByVal lpUnkCP As Any, ByVal lpUnk As Any, ByVal lpIID As Long, ByRef lpPDW As Long) As Long

in IUNknown lpUnkCP - у меня сразу IShockwaveFlash (полученый из AtlAxGetControl(hwnd, SWF))
in IUnknown lpUnk - свой интерфейс. У меня класс FlashEvents. Исходя из этого должен подойти
in IID lpIID - FlashIID as GUID полученный с помощью IIDFromString, совпадает с DIID__IShockwaveFlashEvents из Flash.ocx
out lpPDW - хендл, чтобы использовать в AtlUnAdvise

Использование:

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

ret = AtlAdvise(SWF, MyEvents, VarPtr(FlashIID), myPDW) 'тут получаю 0x80040200 (CONNECT_E_NOCONNECTION)

AtlAdvise C++

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

ATLINLINE ATLAPI AtlAdvise(IUnknown* pUnkCP, IUnknown* pUnk,
                           const IID& iid, LPDWORD pdw)
{
    CComPtr<IConnectionPointContainer> pCPC;
    CComPtr<IConnectionPoint> pCP;

    HRESULT hRes = pUnkCP->QueryInterface(IID_IConnectionPointContainer,
                                              (void**)&pCPC);
    if (SUCCEEDED(hRes))
      hRes = pCPC->FindConnectionPoint(iid, &pCP); // Здесь hRes == 0x80040200
    if (SUCCEEDED(hRes))
      hRes = pCP->Advise(pUnk, pdw);
    return hRes;
}

Что я делаю не так?

Это всё с помощью atl.dll, но ведь VB сам умеет работать с ActiveX. Мб кто расскажет как?

[Хакер]

Вопрос можно свести к такому виду, чтобы для понятия проблемы не нужно было идти на чужой форум и разбираться там в чём-то?

[Jack Ferre]

Я пытаюсь программно создать ActiveX Control (а именно ShockwaveFlash).

Используя CreateObject я получаю объект с методами и свойствами, но толку от него никакого. (1/3 желаемого результата)
Используя AtlAxGetControl lib "atl.dll" я получаю объект и окошко. Уже неплохо. (2/3 желаемого результата)
Остается прикрутить обработчик событий.

Попробывал с помощью AtlAdvise lib "atl.dll"

Creates a connection between an object's connection point and a client's sink.

Получаю ошибку CONNECT_E_NOCONNECTION

Вот исходник с комментариями:

AtlAx.rar

требуется Flash.ocx версии 9 и старше.

(5.17 Кб) Скачиваний: 197

[Хакер]

ATL пока отложим в сторону.

• Экземпляр какого COM-класса ты создаёшь с помощью CreateObject?
• Как понять, что толку от него никакого? Если он бесперспективен, то какой смысл его создавать? Если он не бесперспективен, то опиши суть перспективы? Предпринятие каких шагов дать от бесполезного объекта что-то полезное?
• Какой объект и какое окно ты получешь с помощью AtlAxGetControl. Ты должен используя её получать «объект по окну», а не «объект и окно». Допустим, ты получаешь ссылку на объект по hWnd. Это какой-то второй объект? Ты в итоге имеешь два объекта? Зачем тогда создавал первый?
• На события какого объекта нужно подписаться? Откуда есть достоверная информация, что объект выступает источником событий? Что это за объект, какого класса? Где документирован список его событий?

Код читать преднамеренно не хочу, хочу разобраться в сути замысла. Пока ты всё описываешь так, словно другие всю жизни делали со флешем те же вещи, что сейчас намереваешься сделать ты. А между тем, задача должна быть поставлена так, чтобы она была максимально изолирована от флеш-тематики и касалось только COM-а.

[Хакер]

Ладно, почитал код, был весьма удивлён степенью извращённости действий.

Зачем-то контрол создаётся в ATL-предоставленном контейнере, потом получается ссылка на контрол, потом в него загружается роль, присваиваются какие-то значения Flash-переменным, и затем цикл прокачки сообщений.

По порядку от низкоуровневого к глобальному:

• Автора функции StringFromPointer нужно казнить. Это просто ужас.
• Бессмысленно делать цикл прокачки сообщений на VB: одна из базовых вещей идеологии VB в том, что этот цикл работает в рантайме и VB-программист о нём не думает. Этот цикл сам следит за активными объектами и сам решает, когда ему прекратиться.
• Не понятна идея с порождением контрола в ALT-окне. Почему бы не использовать нормальный штатный для VB подход с контролами?

Поэтому непонятно, почему бы не сделать вот так? Прикладываю пример.

swf_inst_on_form.zip

(4.26 Кб) Скачиваний: 194

Тут в примере Flash10d.ocx. Надеюсь, не будет проблем поменять на др. версию.

[Jack Ferre]

почему бы не сделать вот так?

В таком виде я его (Flash) и использую.
Почему заморачиваюсь с созданием программно:
1. Спортивный интерес.
2. Заметил недавно > зарегистрированный Flash.ocx старше версии 10е(а ему уже 4 года) не дает сохранить VB проект (неведома ошибка)
UPD: 3. (Главное забыл!) Прозрачный фон ActiveX контрола (с серой формой я уже как только не извращался - прозрачнее не становится), но это уже другая тема.

Что это за объект, какого класса?

Класс > ShockwaveFlash.ShockwaveFlash
Интересующий интерфейс > Dispatch IShockwaveFlash; ' которым уже получается пользоваться
Интерфейс событий > Dispatch _IShockwaveFlashEvents; ' IID такой же как у IShockwaveFlash

Бессмысленно делать цикл прокачки сообщений на VB

функция PL_AddItem_Test использовалась мной для измерения скорости передачи строк во Flash. Здесь - только для наглядности. Увидили строку из VB - хорошо, если бы еще событие случилось как в примере swf_inst_on_form.zip было бы просто замечательно.

[Хакер]

В таком виде я его и использую.

Тогда в чём вопрос?

Почему заморачиваюсь с созданием программно:
1. Спортивный интерес.

Окей, но делать это нужно не так.

2. Заметил недавно > зарегистрированный Flash.ocx старше версии 10е(а ему уже 4 года) не дает сохранить VB проект (неведома ошибка)

Это уже другой вопрос. Во-первых, в VB есть по-модульное сохранение. Как с ним обстоят дела? Это может помочь. Во-вторых, надо разобраться, что за ошибка. В-третьих, нужно попробовать запускать VB (runas) от имени администратора. Ну и привести информацию об используемой ОС и о том, установлены ли последние сервис-паки к VB.

Класс > ShockwaveFlash.ShockwaveFlash
Интересуемый интерфейс > Dispatch IShockwaveFlash; ' которым уже получается пользоваться
Интерфейс событий > Dispatch _IShockwaveFlashEvents; ' IID такой же как у IShockwaveFlash

Уже понятно, о чём речь, эти вопросы уже не актуальны.
IID не может быть таким же.
Обработку событий я показал. Надеюсь, руки больше не потянутся к AtlAdvise?

Бессмысленно делать цикл прокачки сообщений на VB

функция PL_AddItem_Test использовалась мной для измерения скорости передачи строк во Flash.

Да причём здесь вообще PL_AddItem_Test? Речь о цикле прокачки сообщений. Он в оригинальном коде вот:

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

    ' Оконный цикл
    Dim hMsg As MSG
    Do While GetMessage(hMsg, 0, 0, 0)
        TranslateMessage hMsg
        DispatchMessage hMsg
    Loop

________

В конце я вообще нахожусь в полном непонимании ситуации. Проблема есть? Или проблемы нет изначально?

[Jack Ferre]

Да причём здесь вообще PL_AddItem_Test? Речь о цикле прокачки сообщений

Извиняюсь, ступил

Созданное окно "AtlAxWin" сразу же умирает без этого цикла.

UPD: 3. (Главное забыл!) Прозрачный фон ActiveX контрола (с серой формой я уже как только не извращался - прозрачнее не становится), но это уже другая тема.

Сделал правку уже после вашего сообщения.

Надеюсь, руки больше не потянутся к AtlAdvise

Потянутся, ведь остался один маленький шаг - AtlAdvise() == S_OK

[Jack Ferre]

IID не может быть таким же.

[code]//Shockwave Flash
Dispatch IShockwaveFlash;
GUID = {D27CDB6C-AE6D-11CF-96B8-444553540000};

//Event interface for Shockwave Flash
Dispatch _IShockwaveFlashEvents;
GUID = {D27CDB6D-AE6D-11CF-96B8-444553540000};

Спасибо за подсказку! Сейчас попробую.

[Хакер]

Созданное окно "AtlAxWin" сразу же умирает без этого цикла.

Ещё раз: тебе не нужно создавать это окно. Тебе нужно использовать экземпляр формы, как в моём примере. Или ты согласен с этим, и значит проблема исчерпана и вопрос решён, или скажи что-то против.

Потянутся, ведь остался один маленький шаг - AtlAdvise() == S_OK

Ещё раз, тебе НЕ НУЖНО ВООБЩЕ даже прикасаться к этой функции. Ты видишь в моём примере вызов этой функции? Нет, её там нет. Причём даже если ты по каким-то неведомым (ибо пока ты не назвал достойного повода) причинам хочешь использовать подход с AtlAxWin, тебе всё равно не нужна AtlAdvise.

Теперь нужно объявить переменную
Dim WithEvents swf As ShockwaveFlashObjectsCtl.ShockwaveFlash
И присваивать ей ссылку. И иметь такие же обработчики событий вида Private Sub swf_eventname

[Jack Ferre]

Теперь нужно объявить переменную и присваивать ей ссылку

Вчера я придумал так же сделать. Запихал код в класс. Понаписал Event-ов.
Но после Call AtlAxGetControl(hwnd, SWF) переменная SWF остается Nothing

UPD: Объявлял так Dim WithEvents swf As ShockwaveFlash, без ShockwaveFlashObjectsCtl. это большая разница?

[Jack Ferre]

Flash.cls:

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

Private sadSWF As ShockwaveFlashObjectsCtl.ShockwaveFlash
Private WithEvents mySWF As ShockwaveFlashObjectsCtl.ShockwaveFlash

Private Sub Class_Initialize()
    Call AtlAxGetControl(G_HWND, sadSWF)
    Set mySWF = sadSWF   ' > ERROR 459
End Sub

Получаю ошибку 459: Object or class does'n support the set of events
А в переменную mySWF ссылка не возвращается.

[Хакер]

Ты обоснуешь, зачем тебе нужно создавать контрол не так, как в моём примере, а так, как ты это делаешь в своём? У меня есть версии, но я хочу услышать причину лично от тебя.

[Jack Ferre]

UPD: 3. (Главное забыл!) Прозрачный фон ActiveX контрола (с серой формой я уже как только не извращался - прозрачнее не становится), но это уже другая тема.

Сделал правку уже после вашего сообщения.

[Хакер]

Каким образом это коррелирует с необходимостью использовать извратный способ порождения экземпляра контрола?

[Jack Ferre]

Таким, что контрол можно будет заставить рисовать на собственном HDC (как? пока понятия не имею)
Если контрол лежит не форме, форму никак не сделать прозрачной.
Если свойсво ShockwaveFlash.WMode сделать "Transparent" у него "отваливается" hwnd и HDC.

Удобство использования в таком виде - как минимум можно проверить зарегистрирован ли Flash.
Без этой возможности программа с грохатом рушится при запуске (вроде "Can't create ActiveX Object")

Запихивание в ресурсы SWF файлов с последующим "кормлением" ими контрола.

[Хакер]

Таким, что контрол можно будет заставить рисовать на собственном HDC (как? пока понятия не имею)

Никак.
Да и лексически это не правильно. Рисовать на hDC нельзя, потому что hDC это хендл. Рисуют на device.

В чём вообще задумка? Сделать полупрозрачный контрол, который бы просвечивал другие контролы или фоновый рисунок? Или сделать полупрозрачное окно, которые просвечивал бы под собой другие окна (свои и окна др. приложений)? Если последнее — то просто используй layered windows.

Удобство использования в таком виде - как минимум можно проверить зарегистрирован ли Flash.
Без этой возможности программа с грохатом рушится при запуске (вроде "Can't create ActiveX Object")

Не правда. Can't create ActiveX object будет не при запуске, а как только ты попытаешься породить экземпляр формы. Поэтому проверяй наличие Флеша до попытки породить форму. Во-вторых, эту ошибку можно перехватить и обработать. Так что не с грохотом.

А вот уже более веская причина: ты можешь (как знаток Флеша) подтвердить, что от версии к версии, от релиза к резилу, они (Adobe) сохраняют постоянство CLSID-а контрола и IID-ов ключевых интерфейсов?

[Jack Ferre]

постоянство CLSID-а контрола

Да, так как в html он создается с помощью CLSID-а уже много лет
Очень удивился, когда нашел в Windows98 SWFlash.ocx 3.0.15 1999 года.
Только что сравнил - CLSID и IID-ы такие же.

[Jack Ferre]

Есть! +1 шаг.
Новая ошибка - CONNECT_E_CANNOTCONNECT = &H80040202
И это последняя строка функции AtlAdvise

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

hRes = pCP->Advise(pUnk, pdw);

Как я и ожидал, мой объект класса FlashEvents был отвергнут, буду мудрить дальше.

[Хакер]

Значит последний довод в пользу создания контрола твоим методом испаряется.

[Хакер]

Как я и ожидал, мой объект класса FlashEvents был отвергнут, буду мудрить дальше.

Я тебе ещё раз говорю. Тебе не нужна AtlAdvise. Тебе нужен WithEvents. Но вообще тебе не нужен WithEvents, тебе нужно обычное рядовое использование контрола.

И не надо мудрить. Для тебя это игра в метод тыка, для меня же — кристально ясный факт того, что твоя попытка подсунуть класс FlashEvents ни за что не будет успешной. Потому что я имею абсолютно ясное представление о том, как устроен механизм событий в COM.

[neit95]

Кстати, касательно ошибки при сохранении. Это случайно не H80004005? Если да, то та же проблема. Работаю из под администратора - не спасает. Вываливается при сохранении именно формы с контролом. Советы support.microsoft.com особо не помогли, по крайней мере подключение daxctle.ocx: при попытке закинуть контролы из этого ocx на форму, для 3 из 4 вываливается сообщение о нехватке памяти . Пробовал перерегистрировать ocx - не помогло.

[Jack Ferre]

2 neit95
Код ошибки не помню, но помню что смысла в ней особого нет, т.е. на конкретную проблему она не указывает.
В интернете решений, кроме как "использовать старую версию", не нашел.

2 Хакер
Как создать фунцкцию, имя которой начинается на "_"?

[Хакер]

Как создать фунцкцию, имя которой начинается на "_"?

Никак / Зачем?

[Jack Ferre]

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

Implements ShockwaveFlashObjectsCtl.[_IShockwaveFlashEvents]

Ошибка: Object module needs to implement 'OnReadyStateChange' for interface '_IShockwaveFlashEvents'
Нужно так:

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

Public Sub _IShockwaveFlashEvents_OnProgress(percentDone As Long)
    ' ...
End Sub

[Хакер]

Слушай. Ты специально делаешь так, чтобы я перестал отвечать?

Я очень не люблю людей, которые приходят с вопросом «Я только что помыл свою кошку, как теперь лучше всего высушить её в микроволновке?», и когда им говоришь «Ни в коем случае не суши кошку в микроволновке, это её убьёт», они говорят «Да, пожалуй ты прав», и через некоторое время продолжают спрашивать «Какой режим микроволновки лучше всего для сушки шерсти?», из чего становится понятно, что от своей идеи они не отказались, хоть им и было сказано, что идея неприемлемая.

А у тебя есть А, у тебя есть Б. Я сказал, как нужно делать А. Я сказал, что если делать А как нужно, то необходимости в Б вообще не будет. Кроме того, я сказал, как правильно делать Б. Но я вижу, что ты и А намерен делать по прежнему не так, как я сказал, и Б тоже намерен делать так, как я сказал не делать. Если ты считаешь, что к моим словам не стоит прислушивать, то я считаю, что нет смысла оказывать помощь.

[VisualFreeBasic]

visual freebasic ide ,code like this:

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

Const ProgID = "ComTest"
Const CLSID_Com = "{920DCEED-B3DD-4110-8F2F-981A554E07FF}"
'Event--------
Const IID___Com = "{62DD544B-09E0-4340-8FF8-41CCC0FD0666}"

Type IClassFactoryImp Extends IClassFactoryVtbl
   Declare Constructor()
End Type


Function IClassFactoryx_QueryInterface(ByVal This As IClassFactory Ptr, ByVal riid As REFIID, ByVal ppvObject As LPVOID Ptr) As HRESULT
   if IsEqualIID(riid, @IID_IUnknown) Then
   ElseIf IsEqualIID(riid, @IID_IDispatch) Then
   ElseIf IsEqualIID(riid, @IID_IClassFactory) Then
   elseif (IsEqualIID(riid, @IID_IConnectionPointContainer)) Then
      MsgBox "控件"
   Else
      RETURN E_NOINTERFACE
   End If
    *ppvObject = This
   Return S_OK
End Function

Function IClassFactoryx_AddRef(ByVal This As IClassFactory Ptr) As HRESULT
   Return S_OK
End Function

Function IClassFactoryx_Release(byVal This As IClassFactory Ptr) As HRESULT
   Return S_OK
End Function

Function IClassFactoryx_CreateInstance(byval This as IClassFactory ptr, byval pUnkOuter as IUnknown ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
   if IsEqualIID(riid, @IID_IUnknown) Then
   ElseIf IsEqualIID(riid, @IID_IDispatch) Then
   ElseIf IsEqualIID(riid, @IID_IClassFactory) Then
       *ppvObject = this
      Return S_OK
   Else
      RETURN E_NOINTERFACE
   End If
   dim IDB As IDispatch ptr = New IDispatch
   IDB->lpVtbl = New Demo()
   *ppvObject = IDB
   IUnknown_Release(IDB)
   return S_OK
End Function

Function IClassFactoryx_LockServer(byval This as IClassFactory ptr, byval fLock as WINBOOL) as HRESULT
   return S_OK
End Function

Constructor IClassFactoryImp()
   This.QueryInterface = @IClassFactoryx_QueryInterface '0
   This.AddRef = @IClassFactoryx_AddRef '4
   This.Release = @IClassFactoryx_Release '8
   This.CreateInstance = @IClassFactoryx_CreateInstance '12
   This.LockServer = @IClassFactoryx_LockServer '16
End Constructor

Type Demo Extends IDispatchVtbl
   
   TestOpen As function(ByVal This As IDispatch Ptr) As HRESULT'32
   Declare Constructor()
End Type

Function Demo_QueryInterface(ByVal This As IDispatch PTR, ByVal riid As REFIID, ByVal ppvObject As LPVOID Ptr) As HRESULT
   if IsEqualIID(riid, @IID_IUnknown) Then
   ElseIf IsEqualIID(riid, @IID_IDispatch) Then
   ElseIf (IsEqualIID(riid, @IID_IConnectionPointContainer)) Then
      MsgBox "这是要找控件"
   Else
      RETURN E_NOINTERFACE
   End If
    *ppvObject = This
   Return S_OK
End Function

Function Demo_AddRef(ByVal This As IDispatch PTR) As HRESULT
   Return S_OK
End Function

Function Demo_Release(ByVal This As IDispatch PTR) As HRESULT
   Return S_OK
End Function

Function Demo_GetTypeInfoCount(ByVal This As IDispatch PTR, ByVal pctinfo As UINT Ptr) As HRESULT
    *pctinfo = 0
'   MsgBox "Demo_GetTypeInfoCount"
   Return S_OK
End Function

Function Demo_GetTypeInfo(ByVal This As IDispatch PTR, ByVal iTInfo As UINT, ByVal lcid As LCID, ByVal ppTInfo As ITypeInfo Ptr Ptr) As HRESULT
'   Dim TI As ITypeInfo Ptr=New ITypeInfo
'   TI->lpVtbl=new TypeInfoImp
'   *ppTInfo=TI
'   MsgBox "Demo_GetTypeInfo"
   Return S_OK
End Function

Function Demo_GetIDsOfNames(ByVal This As IDispatch PTR, ByVal riid As Const IID Const Ptr, ByVal rgszNames As LPOLESTR Ptr, ByVal cNames As UINT, ByVal lcid As LCID, ByVal rgDispId As DISPID Ptr) As HRESULT
   Select case *rgszNames[0]
      Case "Add"
          *rgDispId = 1
   End Select
   Return S_OK
End Function

Function Demo_Invoke(ByVal This As IDispatch PTR, ByVal dispIdMember As DISPID, ByVal riid As Const IID Const Ptr, ByVal lcid As LCID, ByVal wFlags As WORD, ByVal pDispParams As DISPPARAMS Ptr, ByVal pVarResult As VARIANT Ptr, ByVal pExcepInfo As EXCEPINFO Ptr, ByVal puArgErr As UINT Ptr) As HRESULT
   Dim p As Parameters
   p.Count = pDispParams->cArgs
   if p.Count > 0 then
      ReDim p.Item(p.Count -1)
      For i As Long = 0 to pDispParams->cArgs -1
         p.Item(i).Value = pDispParams->rgvarg[i]
      Next
   end if
   select case dispIdMember
      Case 1
         Dim r As Long
         r = p.Item(0).Value.lVal + p.Item(1).Value.lVal
          *pVarResult = CVAR(r)
   End Select
   Return S_OK
End Function

Function Demo_Open(ByVal This As IDispatch PTR) As HRESULT
   MsgBox"test"
   Return S_OK
End Function

Constructor Demo()
   This.QueryInterface = @Demo_QueryInterface '0
   This.AddRef = @Demo_AddRef '4
   This.Release = @Demo_Release '8
   This.GetTypeInfoCount = @Demo_GetTypeInfoCount '12
   This.GetTypeInfo = @Demo_GetTypeInfo '16
   This.GetIDsOfNames = @Demo_GetIDsOfNames '20
   This.Invoke = @Demo_Invoke '24
   This.TestOpen = @Demo_Open '28
End Constructor

Sub test()
   Dim IDB As IDispatch Ptr = New IDispatch
   IDB->lpVtbl = New Demo
   Dim ret As VARIANT
   DispCallFunc(IDB, 28, 1, vbLong, 0, 0, 0, @ret)
End sub


[VisualFreeBasic]

form1:

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

Option Explicit
Dim ExcelApp As Object
Private Sub Command1_Click()
    Set ExcelApp = CreateObject("excel.application")
    Advise ExcelApp
    ExcelApp.Visible = True
    ExcelApp.WorkBooks.Add
End Sub



basefile:

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

Option Explicit

Type CSink
    Interfaces As Long
    RefCount As Long
    EventIID As UUID
End Type

Private IID_IUnknown As UUID
Private IID_IDispatch As UUID

Dim vtable(0 To 6) As Long

Private Function EventSink_QueryInterface(This As CSink, RIID As UUID, lObj As Long) As Long
    On Error GoTo ErrLine
    If IsEqualGUID(RIID, IID_IUnknown) Then
        lObj = VarPtr(This)
        This.RefCount = This.RefCount + 1
    ElseIf IsEqualGUID(RIID, IID_IDispatch) Then
        lObj = VarPtr(This)
        This.RefCount = This.RefCount + 1
    ElseIf IsEqualGUID(RIID, This.EventIID) Then
        lObj = VarPtr(This)
        This.RefCount = This.RefCount + 1
    Else
        lObj = 0
        EventSink_QueryInterface = E_NOINTERFACE
    End If
ErrLine:
End Function

Private Function EventSink_AddRef(This As CSink) As Long
    This.RefCount = This.RefCount + 1
    EventSink_AddRef = This.RefCount
End Function

Private Function EventSink_Release(This As CSink) As Long
    This.RefCount = This.RefCount - 1
    EventSink_Release = This.RefCount
    If This.RefCount = 0 Then GlobalFree VarPtr(This)
End Function

Private Function EventSink_GetTypeInfoCount(This As CSink, pctinfo As Long) As Long
    pctinfo = 0                                                                 ' Not implemented
    EventSink_GetTypeInfoCount = E_NOTIMPL
End Function

Private Function EventSink_GetTypeInfo(This As CSink, ByVal iTInfo As Long, ByVal lcid As Long, ppTInfo As Long) As Long
    ppTInfo = 0
    EventSink_GetTypeInfo = E_NOTIMPL
End Function

Private Function EventSink_GetIDsOfNames(This As CSink, RIID As UUID, rgszNames As Long, ByVal cNames As Long, ByVal lcid As Long, rgDispId As Long) As Long
    EventSink_GetIDsOfNames = E_NOTIMPL
End Function

Private Function EventSink_Invoke(This As CSink, ByVal dispIdMember As Long, RIID As olelib.UUID, ByVal lcid As Long, ByVal wFlags As Integer, ByVal pDispParams As Long, ByVal pVarResult As Long, pExcepInfo As olelib.EXCEPINFO, puArgErr As Long) As Long
    Dim a() As Variant
   
    OnEvent dispIdMember
    EventSink_Invoke = S_OK                                                     ' This method never fails
End Function

Private Function AddrOf(ByVal Add As Long) As Long
    AddrOf = Add
End Function
Private Function OnEvent(ByVal dispIdMember As Long) As Long
    Form1.List1.AddItem "事件ID:" & dispIdMember
End Function
Public Function CreateSink(EventIID As UUID) As Object
    Dim lEventSinkPtr As Long, lOldProt As Long
    vtable(0) = AddrOf(AddressOf EventSink_QueryInterface)
    vtable(1) = AddrOf(AddressOf EventSink_AddRef)
    vtable(2) = AddrOf(AddressOf EventSink_Release)
    vtable(3) = AddrOf(AddressOf EventSink_GetTypeInfoCount)
    vtable(4) = AddrOf(AddressOf EventSink_GetTypeInfo)
    vtable(5) = AddrOf(AddressOf EventSink_GetIDsOfNames)
    vtable(6) = AddrOf(AddressOf EventSink_Invoke)
    Dim EventSink As CSink
    With EventSink
        .Interfaces = VarPtr(vtable(0))
        .RefCount = 1
        .EventIID = EventIID
    End With
    lEventSinkPtr = GlobalAlloc(GPTR, LenB(EventSink))
    If lEventSinkPtr Then
        MoveMemory ByVal lEventSinkPtr, EventSink, LenB(EventSink)
        MoveMemory CreateSink, lEventSinkPtr, 4
        CLSIDFromString IIDSTR_IUnknown, IID_IUnknown
        CLSIDFromString IIDSTR_IDispatch, IID_IDispatch
    Else
        Err.Raise 7, "CreateEventSink"
    End If
End Function

Sub Advise(EventObject As Object, Optional SourceIID As String)
    On Error GoTo ErrLine
    Dim oCPC As IConnectionPointContainer
    Dim oEnm As IEnumConnectionPoints
    Dim oCP As IConnectionPoint
    Dim oUnk As olelib.IUnknown
    Dim tIID As UUID
    Dim lCookie As Long
    Set oCPC = EventObject
    If LenB(SourceIID) = 0 Then
        Set oEnm = oCPC.EnumConnectionPoints
        oEnm.Next 1, oCP
        oCP.GetConnectionInterface tIID
    Else
        CLSIDFromString SourceIID, tIID
        Set oCP = oCPC.FindConnectionPoint(tIID)
    End If
    Set oUnk = CreateSink(tIID)
    lCookie = oCP.Advise(oUnk)
    Exit Sub
Disconnect:
    oCP.Unadvise lCookie
ErrLine:
End Sub




[VisualFreeBasic]

you can use TLBINF32.DLL,LIST ALL EVENT NAME,GUID,CLSID,AND ARGS NAME,ARGS type,so it's good