|
|
|
| |
|
VisualBasic & C++ & PowerBasic - Forum
|
|
|
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Es geht. 
In PowerBASIC können wir ActiveX-Controls nicht nur via Eigenschaften und Methoden angehen, sondern nun auch als Client für deren Events fungieren. Sprich: Es ist möglich ohne Fremdsoftware ActiveX in vollem Umfang zu supporten!
Und: Es ist sogar leichter, als nach dem Umfang und Mangel an guter Information über COM möglich schien. Vieles wurde geschrieben und beschrieben, aber immer wieder bin ich über Events gestolpert. Irgendwie lag da eine unüberwindliche Barriere, die heute aber wie weggewischt ist.
Basierend auf einer Arbeit von Thorsten Rinow: Events in pure PB7-Code (siehe www.PowerBASIC.Com) habe ich die Sache etwas vereinfacht. Vor allem: Völlig von Assembler befreit  So dass man der Sache eigentlich folgen kann - ohne nun direkt ASM zu beherrschen.
Fangen wir am besten mit etwas Theorie an (keine Angst ).
Eine ActiveX-Komponente kann Events in zwei Formen anbieten: Einmal als VTable, ConnectionVT, und oder als dispinterface Connectable. Dabei stellt die ActiveX-Komponente diese Eventsets als sogenanntes Outgoing Interface zur Verfügung. Der Client kann daran andocken und muss aber die Events, die verwendet werden sollen, implementieren und dem ActiveX-Control in einem Eventsink-Interface zur Verfügung stellen.
Genau am letzten Satz lagen bisher unsere unüberwindbaren Probleme: Wie erzeugen wir in PB ein Interface? Dieses Interface erwartet das ActiveX-Control von seinem Client, wobei es eigentlich ein einfaches IDispatch-Interface ist, das die Verbindung dann ermöglicht bzw. über das die Kommunikation zwischen beiden, Server und Client, dann läuft.
Wie geht das nun mit dem Events?
Eine ActiveX-Komponente die über Outgoing-Interfaces, also Events, verfügt, MUSS! ein Interface namens: IConnectionpointContainer implementieren. Ein Client, der wissen will, ob das Control Events hat prüft also über die Instanz des Controls, via IUnknown:(QueryInterface() ob das Control IConnectionpointContainer implementiert hat. Hierzu wird QueryInterface die IID des Interfaces, die bekannt ist (kann notfalls sogar aus der Registry geholt werden, oder man verwendet den Ole-Viewer (bei jedem SDK als Tool mit dabei).
IID_IConnectionpointContaier = GUID$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
Erhält man als Rückgabewert: %E_NOTIMPL hat sich die Frage schnell erledigt: Pech, keine Events. Erhält man jedoch einen Interfacepointer und der Rückgabewert ist %S_OK, so weiß Client: Ah! Das Control bietet Events an.
Bevor wir da aber weiter machen, zunächst mal die Frage klären: Wie kann man in PowerBASIC eigentlich Objekte erzeugen? Wie erstellt man ein Interface, wie kommen wir dazu, etwas mit einem Interface anzufangen?
Das hat Thorsten elegant gelöst: Via CoTaskMemAlloc()! Wir fordern einfach Speicher von Ole und pflanzen dort unsere Pointer ein - oder lassen sie in dem von uns angeforderten Speicher pflanzen!
Schließlich besteht ein Objekt ja aus nichts anderem als organisiertem Speicher. Die Betonung liegt auf "ORGANISIERT". Hier hat Thorsten wahrlich mal Ordnung ins Chaos gebracht durch einen kleinen Trick mit einer UDT:
Code:
TYPE Vtbl
fPtr AS DWORD PTR
Count AS DWORD
END TYPE
Tatsächlich ist es mit diesem kleinen Dreh möglich, jedes beliebige Interface aus dem Speicher zu erzeugen! Der Zugriff auf solch ein Interface ist:
ObjektPointer->VTable->IUnknown
Dim pObj As Vtbl PTR
bildet genau die genannte Reihe ab. Count ist dazu noch eine Beigabe, die eigentlich für das reine Interface nicht erforderlich wäre. Bringen wir mal leben in die Bude: Wir wollen ein Interface namens: IConnectionpointContainer zum leben erwecken ...
Ok: Zuerst dimensioniere ich mal die Interface-Variable, die dann zum später zum Objekt wird!
Dim IConnectionpointContainer As VTbl PTR
Und schon hat man es:
ObjektPointer->VTable
Das Ding ist aber noch leer. Das wird nun mit Speicher eingehüllt:
IConnectionpointContainer = CoTaskMemAlloc(8)
die 8 ist klar, weil die UDT 8 Bytes groß ist: fPtr = 4 Bytes und Count = 4 Bytes
Der Member fPtr ist der Funktionszeiger oder die VTable die auf Funktionen zeigt. Auch für die VTable brauchen wir Speicher, aber wieviel? Schaut man in der MSDN nach, oder sucht im Internet über IConnectionPointContainer so stellt man fest, dass IConnectionpointContainer aus folgenden Funktionen besteht (in the VTable-Order)
QueryInterface
Addref
Release
EnumConnectionPoints
FindConnectionPoint
folglich brauchen wir Speicher der 5 Funktionszeiger aufnehmen kann: 5 * 4 = 20 Bytes. Daraus folgt dann weiter:
@IConnectionpointContainer.fPtr = CoTaskMemAlloc(20)
fPtr ist ja auch ein Pointer!folglich kann über den auf einen beliebige Funktion zugreifen, via:
@fPtr[2] (das würde direkt Release anspringen)
zusammengefasst:
Code:
Dim IConnectionpointContainer As Vtbl PTR
IConnectionpointContainer = CoTaskMemAlloc(8)
@IConnectionpointContainer.fPtr = CoTaskMemAlloc(20)
Wir haben einen Interfacezeiger: IConnectionpointContainer
einen Zeiger auf die VTable des Objekts: @IConnectionpointContainer
Die VTable und Funktionszeiger: @IConnectionpointContainer.@fPtr[Nr_der_Funktion]
Wenn wir das Interface kicken wollen genügt einfach:
CoTaskMemFree IConnectionpointContainer.
voila  Aber: Das brauchen wir nur dann, wenn wir selbst ein Interface erstellen. Viele Funktionen liefern einfach ein IUnknown-Interface zurück. Dazu erübrigt sich die Speicher-Bereitstellung, weil dies ja das zurückliefernde Objekt tut.
Thorsten hatte eine Komponente verwendet: ADODB.Connection. Das bietet sich an. Aus dem einen Grund: Weil es zwei Events feuert, wenn man eine Connection erstellt und zum Anderen Grund: Es demonstriert, dass auch fensterlose Komponente Events feuern können! Das ist also nicht auf reine GUI-Controls beschränkt, sondern eine wirklich fundamentale Sache.
Der Weg zu IConnectionpointContainer.
Wir können sagen:
Dim myObj As Dispatch
Set myObj = New Dispatch In "ADODB.Connection"
und schon haben wir eine Instanz von ADODB.Connection. myObj ist der Objektpointer auf die VTable des Interfaces: ADODB.Connection. Aber: myObj ist gekapselt. Man könnte sagen: VarPtr(myObj) ist QueryInterface, das wirkt aber wenig elegant. Nun: Wir können uns ja ein IUnknown - Interface auf bekanntem Weg basteln - oder aber: PB untestützt IUnknown und IDispatch! wenn auch unkommentiert.
Aha ... dann los:
Code:
Dim myObj As Dispatch
Dim pUnk As IUnknown
Set myObj = New Dispatch In "ADODB.Connection"
If ObjPtr(myObj) = 0 Then Exit ...
Set pUnk = myObj
setzt das IUnknown-Interface von myObj direkt in meine IUnknown-Variable und durch sie greife ich
auf das dahinterliegende Objekt zu, was meint: Ich frage IUnknown.QueryInterface() ob IConnectionpointContainer in dem Objekt irgendwelche Aktien hat. Wenn ja, dann hat es Events! QueryInterface benötigt nur die IID_IConnectionpointContainer und liefert, wenn bekannt, einen Zeiger auf IUnknown darauf zurück. Sprich: Das Objekt wird frisch instantiiert geliefert! Daher ist es sehr wichtig, dass man schon mal Speicher für das neue Objekt in der Hand hat - und schon schließt sich mal ein Kreis:
Code:
TYPE Vtbl
fPtr AS DWORD PTR
Count AS DWORD
END TYPE
Dim IConnectionpointContainer As Vtbl PTR
Dim pUnk As IUnknown
Dim myObj As Dispatch
Dim IID_IConnectionpointContainer As Guid
Dim rVal As DWORD
Set myObj = New Dispatch In "ADODB.Connection"
If ObjPtr(myObj) = 0 Then Exit Function
Set pUnk = myObj
IID_IConnectionpointContainer = GUID$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
rVal = pUnk.QueryInterface(IID_IConnectionpointContainer, Byval Varptr(IConnectionpointContainer))
Prego! Ist nun rVal = %S_OK so unterstützt die Komponente Events, wenn nicht, Pech gehabt. Im Fall wir bekommen %S_OK so wurde unser Interfacezeiger nun lebendig: Es beherbergt IConnectionpointContainer.
Schön, schön: Wir wissen jetzt: Diese Komponente unterstützt Events  Schön! Aber welche?
Wie man sehen kann unterstützt IConnectionpointContainer nebst dem allgegenwärtigen IUnknown, das alle Interfaces unterstützen müssen, zwei Methoden: EnumconnectionPoints und FindConnectionPoint. FindConnectionpoint kommt bei early Binding zum Zuge, wenn also der Client via einer Typenbibliothek weiß, welches Interface hierfür in Betracht kommt. Wir aber haben: Keine Ahnung! Als Ahnungsloser frägt man daher EnumConnectionpoints ab, welche das wären. Ein Objekt kann beliebig viele Connectionpoints haben. Prüft man diese Methode: EnumConnectionPoints so wird klar, man bekommt nicht einen bestimmten ConnectionPoint, sondern eine Enumerator-Interface mittels dem in den Connectionpoints iteriert werden kann. Also ist wieder ein neues Interface angesagt - her mit dem Speicher
IEnumConnectionPoints besteht aus
IUnknown
Next
Skip
Reset
Clone
Also 7 Funktionspointer (4 + 3 aus IUnknown)
Dim IEnumconnectionPoints As Vtbl Ptr
Dann rufen wir die Methode in IConnectionpointcontainer mal auf ... aber wie? PowerBASIC kann mit CALL DWORD beliebige Funktionen nur über einen Funktionszeiger aufrufen, allerdings wird dazu ein Funktionsprototyp für das Schlüsselwort USING benötigt, wenn Parameter übergeben werden müssen. Wenn wir in PB Interfaces aufrufen müssen wir immer zumindest 1 Parameter mitgeben, den sogenannten This-Pointer, das ist der Zeiger auf das Interface. Rufe ich aus der VTable von IConnectionpointContainer eine Funktion auf, muss immer IConnectionpointContainer in der Funktion mit angegeben werden. Was wir also brauchen sind Funktionsprototypen für verschiedene Aufrufe - oder EierlegendeWollmilchsäue. Funktionsprototypen werden in PB mittels Declare-Anweisungen erzeugt:
Code:
DECLARE FUNCTION PInvoke (BYVAL pInterface AS DWORD) AS LONG
DECLARE FUNCTION PInvoke1 (BYVAL pInterface AS DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke2 (BYVAL pInterface AS DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke3 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke4 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD, DWORD) AS LONG
PInvoke plus Zahl sagt wieviele Parameter damit übergeben werden können. Warum nicht: Optional?
Vergiß es! Um solche Prototypen zu erstellen muss CDECL der Funktion vorangestellt werden was dann meint: Aufruf nach C-Konvention: Von Rechts nach links auf den Stack. Daher wandert der InterfacePointer als letztes auf den Stack. Nach LIFO-Wandert damit der Interfacezeiger zuerst vom Stack und der äußerste rechte Parameter wird von ASM als Funktionspointer angesehen und Call ...
macht einen Ausflug ins Niervana. Die Sache muss _stdCall angegangen werden. Der InterfacePointer ist der Erste in der Funktion, aber der LETZTE! im Stack. Und damit der Erste der vom Stack gezogen wird und der wirkliche Funktionspointer bleibt als Rest da. Das ist korrekt.
Welchen Prototyp brauchen wir? Nun: Man schaue in der MSDN nach, das die Methode EnumconnectionPoints des IConnectionpointContainers 1 Parameter hat: Ein Pointer auf das Interface EnumconnectionPoints. Wir brauchen also PInvoke1(...).
Let's go:
Code:
TYPE Vtbl
fPtr AS DWORD PTR
Count AS DWORD
END TYPE
DECLARE FUNCTION PInvoke (BYVAL pInterface AS DWORD) AS LONG
DECLARE FUNCTION PInvoke1 (BYVAL pInterface AS DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke2 (BYVAL pInterface AS DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke3 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke4 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD, DWORD) AS LONG
Dim IConnectionpointContainer As Vtbl PTR
Dim IEnumconnectionPoints As Vtbl PTR
Dim pUnk As IUnknown
Dim myObj As Dispatch
Dim IID_IConnectionpointContainer As Guid
Dim rVal As DWORD
Set myObj = New Dispatch In "ADODB.Connection"
If ObjPtr(myObj) = 0 Then Exit Function
Set pUnk = myObj
IID_IConnectionpointContainer = GUID$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
rVal = pUnk.QueryInterface(IID_IConnectionpointContainer, Byval Varptr(IConnectionpointContainer))
If rVal <> %S_OK Then Exit Function 'Falsch! Objekte aufräumen, wird aber sonst unübersichtlich ...
'get the IEnumInterfacepointer
Call Dword @IConnectionpointContainer.@fPtr[3] Using pInvoke1(IConnectionpointContainer, _
Byval Varptr(IEnumconnectionPoints)) to rVal
If rVal <> %S_OK Then Exit Function '...
'METHOD: RESET aufrufen
Call Dword @IEnumConnectionPoints.@fPtr[5] Using pInvoke(IEnumConnectionPoints) to rVal
Die Methode Reset hat den Iterator von IEnumConnectionPoints vor den Beginn des ersten Connectionpoint (ist da einer?!) gesetzt, also initialisiert. Mittels der Methode Next kann man entweder einzeln durch IConnectionpointContainer steppen - oder man kann ein Array bilden und einfach mal so mehrere angeln. Uns genügt nur 1er und demzufolge genügt ein Einzelschritt um einen Connectionpoint zu erwischen In der MSDN haben wir gecheckt, dass die Methode Next von IEnumconnectionPoints 3 Parameter hat, wir brauchen also pInvoke3-Prototyp. Zuerst brauchen wir aber ein IConnectionpoint-Interface, weil der Iterator sofort die Intefaces zurückwirft!
Create it In der MSDN haben wir gecheckt, dass IConnectionPoint insgesamt 8 Funktionspointer hat, also wir brauchen dafür 32 Bytes Speicher für die VTable.
Code:
TYPE Vtbl
fPtr AS DWORD PTR
Count AS DWORD
END TYPE
DECLARE FUNCTION PInvoke (BYVAL pInterface AS DWORD) AS LONG
DECLARE FUNCTION PInvoke1 (BYVAL pInterface AS DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke2 (BYVAL pInterface AS DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke3 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke4 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD, DWORD) AS LONG
Dim IConnectionpointContainer As Vtbl PTR
Dim IEnumconnectionPoints As Vtbl PTR
Dim IConnectionPoint AS Vtbl PTR
Dim pUnk As IUnknown
Dim myObj As Dispatch
Dim IID_IConnectionpointContainer As Guid
Dim rVal As DWORD
Dim count As DWORD
Set myObj = New Dispatch In "ADODB.Connection"
If ObjPtr(myObj) = 0 Then Exit Function
Set pUnk = myObj
IID_IConnectionpointContainer = GUID$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
rVal = pUnk.QueryInterface(IID_IConnectionpointContainer, Byval Varptr(IConnectionpointContainer))
If rVal <> %S_OK Then Exit Function 'Falsch! Objekte aufräumen, wird aber sonst unübersichtlich ...
'get the IEnumInterfacepointer
Call Dword @IConnectionpointContainer.@fPtr[3] Using pInvoke1(IConnectionpointContainer, _
Byval Varptr(IEnumconnectionPoints)) to rVal
If rVal <> %S_OK Then Exit Function '...
'METHOD: RESET aufrufen
Call Dword @IEnumConnectionPoints.@fPtr[5] Using pInvoke(IEnumConnectionPoints) to rVal
Call Dword @IEnumConnectionPoints.@fPtr[3] USING PInvoke3(IEnumConnectionPoints, _
1, BYVAL VARPTR(IConnectionPoint), i) TO rVal
rVal hat nun was, wieso ich Microsoft eigentlich unendlich schätze und liebe: OLE gibt immer
%S_OK bei erfolgreicher Ausführung zurück. Jeder muss sich daran halten. Jeder? Nein, in
Redmond gibt es eine einstige Garagenfirma die es fertig bringt sich NICHT DARAN zu halten! Obwohl
dieser Standard von denen festgelegt wurde. Wurde ein ConnectionPoint gefunden und damit gleichzeitig instantiiert, so gibt rVal eine 1 zurück! Ist %S_OK der Wert, so ist die Funktion fehlgeschlagen. Ist rVal und i auf 1 so haben wir einen Connectionpoint, mit dem man nun fröhlich connecten kann.
Damit gehts auf einer anderen Seite weiter.
Bearbeitet von Lordchen (18:41 25/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Im ersten Teil wurde gezeigt, wie man über IConnectionpointcontainer und EnumconnectionPoints einen Connectionpoint instantiieren (ok: finden ) lässt. Das ist eigentlich schon viel, weil ein Aufruf von Advise mit einem geeigneten Dispinterface des Clienten schon die Connection herstellen kann. Der Client würde dann Events empfangen - sofern der Server welche feuert.
Wir stellen uns so, dass wir keine Ahnung haben welche Events das Ding, was wir da als Komponente instanziiert haben, eigentlich supportet.
Wie kitzeln wir aus dem Ding nun diese wichtigen Informationen heraus?
Nun: Wir haben den ConnectionPoint und lassen uns mal dessen IID heraus geben. Mittels dieser IID kann das Interface in einer TypeLib eindeutig identifiziert werden - also her damit Weiter: Events bedürfen fast zwingend eines IDispatch Interface, was also jede Komponenten implementiert haben muss, die Events feuert.
Gucken wir mal IConnectionpoint an:
IUnknown
GetConnectionInterface ' hört sich mal nicht schlecht an ....
GetConnectionpointContainer 'naja: back to the roots ....
Advise 'hier gehts dann ab ,)
UnAdvise 'hier hörts dann wieder auf
EnumConnections 'ja: Ein Conpoint kann mehrere Verbindungen gleichzeitig.
Der Kandidat wurde gefunden: Es ist eindeutig: GetConnectionInterface was uns die IID zu diesem Connectionpoint-Interface zurück gibt. Zuerst erlösen wir aber IEnumconnectionPoints, weil
wir das Interface nicht mehr benötigen. Wir lösen Release aus. Dann holen wir die IID_DispInterface
des IConnectionpoints
Let's go:
Code:
FUNCTION CreateDispEvents(BYVAL sProgID AS STRING, mobj AS VARIANT) AS LONG
DIM clsIDProg AS GUID
DIM IID AS GUID
DIM IID_Connection AS GUID
DIM obj AS DISPATCH
DIM rVal AS DWORD
DIM pUnk AS IUnknown
DIM pDisp AS IDispatch
DIM Container AS W_Vtbl PTR
DIM EnumPoints AS W_Vtbl PTR
DIM ConPoint AS W_Vtbl PTR
DIM ITypeInfo AS W_Vtbl PTR
DIM ITypeLib AS W_Vtbl PTR
DIM EnumCon AS W_Vtbl PTR
DIM n AS DWORD
DIM m AS LONG
DIM i AS DWORD
DIM b AS DWORD
DIM fooName AS BYTE PTR
DIM sfoo AS STRING
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
SET obj = NEW DISPATCH IN sProgiD
IF OBJPTR(obj) = 0 THEN EXIT FUNCTION
SET pUnk = obj
'IConnectionPointContainer
IID = GUID$($IID_ICPC)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(Container))
IF rVal <> %S_OK THEN GOTO CleanUp1
'IEnumConnectionPoints
CALL DWORD @Container.@fPtr[3] USING PInvoke1(Container, BYVAL VARPTR(EnumPoints)) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp2
'Zurücksetzen - reset
CALL DWORD @EnumPoints.@fPtr[5] USING PInvoke(EnumPoints) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp2
'IConnectionPoint
CALL DWORD @EnumPoints.@fPtr[3] USING PInvoke3(EnumPoints, 1, BYVAL VARPTR(ConPoint), i) TO rVal
IF rVal = 0 THEN GOTO CleanUp2
'Release IEnumConnectionPoints
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
CALL DWORD @ConPoint.@fPtr[3] USING PInvoke1(ConPoint, BYVAL VARPTR(IID_Connection)) TO rVal
IID = GUID$($IID_IDispatch)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(pDisp))
IF rVal = %S_OK THEN
rVal = pDisp.GetTypeInfo(0, %NULL, BYVAL VARPTR(ITypeInfo))
IF rVal = %S_OK THEN
CALL DWORD @ItypeInfo.@fPtr[18] USING PInvoke2(ItypeInfo, ITypeLib, i) TO rVal
CALL DWORD @ITypeInfo.@fPtr[2] USING PInvoke(ITypeInfo)
IF rVal = %S_OK THEN
CALL DWORD @ITypeLib.@fPtr[6] USING PInvoke2(ITypeLib, BYVAL VARPTR(IID_Connection), _
BYVAL VARPTR(ITypeInfo)) TO rVal
IF rVal = %S_OK THEN
'GetTypeAttributes
DIM ttyp AS TYPEATTR PTR
DIM tfunc AS FUNCDESC PTR
CALL DWORD @ITypeInfo.@fPtr[3] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
IF rVal = %S_OK THEN
FOR i = 0 TO @ttyp.cFuncs-1
CALL DWORD @ITypeInfo.@fPtr[5] USING PInvoke2(ITypeInfo, BYVAL i, BYVAL VARPTR(tfunc)) TO rVal
CALL DWORD @ITypeInfo.@fPtr[7] USING PInvoke4(ITypeInfo, BYVAL @tfunc.memid, fooname, BYVAL 1, b) TO rVal
sfoo = sfoo & GetBString(fooname) & CHR$(13)
CALL DWORD @ITypeInfo.@fPtr[20] USING PInvoke1(ITypeInfo, BYVAL VARPTR(tfunc)) TO rVal
NEXT
END IF
CALL DWORD @ITypeInfo.@fPtr[19] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
END IF
END IF
END IF
END IF
MSGBOX sfoo
CleanUp2:
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
CoTaskMemFree EnumPoints
CleanUp1:
CoTaskMemFree Container
SET obj = NOTHING
END FUNCTION
Informationen über Beschreibungen hat eigentlich nur das IDispatch-Interface in Verwaltung:
ITypeInfo und ITypeLib Interfaces also im Köcher. IConnectionPoint kann uns als einfaches IUnknown-Interface da nicht mehr weiter helfen, aber wir haben IConnectionPoint ja die IID abgenötigt
Wir müssen also das IDispatch Interface unserer Komponente bemühen.
Ruft man das so auf:
CreateDispEvents "MSFlexGridLib.MSFlexGrid", vObj
Kommt das
Bearbeitet von Lordchen (14:12 23/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Antwort: Ja!
Aber:
Kommt darauf an, was man darunter versteht. Ich verstehe unter Automation, dass man eine beliebige Komponente ins Programm nimmt, die sich dann automatisch der PB-Umgebung annimmt.
WoW? - ja. Das geht.
Voraussetzung:
Funktionen und Sub's die wir teilen wollen müssen wir veröffentlichen. Das heißt: Ein einfaches: Export anhängen. Funktionen oder Sub's die wir hidden, sind nicht mit dem Export versehen haben aber auch keinen Automationssupport.
Die Frage ist die: Ich kämme ein Objekt nach seinen Eigenschaften, Methoden und (wie hier beschrieben) auch Events durch und kenne die Namen der in Betracht zu ziehenden Funktionen. Habe ich in PowerBasic einige Funktionen (auch als Exe!) Exportiert so bekomme ich davon ganz locker einen Funktionspointer:
nFooPtr = GetProgAddress(GetModulehandle(""), "Name_der_Funktion")
Da jedes Objekt seinen Eigenen Satz an Funktionen anbietet, so kann selbst damit eine IUnknown-Connection automatisiert werden.
Für Automation der Events wäre also:
Code:
FUNCTION InfoMessage ALIAS "InfoMessage" ( Sender AS IUnknown, pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "InfoMessage", %MB_OK, "EVENT"
END FUNCTION
FUNCTION BeginTransComplete ALIAS "BeginTransComplete" ( Sender AS IUnknown, TransactionLevel AS LONG, pError AS DWORD, adStatus AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "BeginTransComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION RollbackTransComplete ALIAS "RollbackTransComplete" ( Sender AS IUnknown, BYVAL pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "RollbackTransComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION CommitTransComplete ALIAS "CommitTransComplete" ( Sender AS IUnknown, BYVAL pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "CommitTransComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION WillExecute ALIAS "WillExecute" ( Sender AS IUnknown, Source AS DWORD, CursorType AS DWORD, LockType AS DWORD, Options AS DWORD, adStatus AS DWORD, _
pCommand AS DWORD, pRecordset AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "WillExecute", %MB_OK, "EVENT"
END FUNCTION
FUNCTION ExecuteComplete ALIAS "ExecuteComplete" ( Sender AS IUnknown, RecordsAffected AS DWORD, pError AS DWORD, adStatus AS DWORD, pCommand AS DWORD, _
pRecordset AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "ExecuteComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION WillConnect ALIAS "WillConnect" ( Sender AS IUnknown, ConnectionString AS STRING, UserID AS DWORD, Password AS DWORD, Options AS DWORD, _
adStatus AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "WillConnect" + $CRLF + $CRLF + ACODE$(ConnectionString), %MB_OK, "EVENT"
END FUNCTION
FUNCTION ConnectComplete ALIAS "ConnectComplete" ( Sender AS IUnknown, pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "ConnectComplete", %MB_OK, "EVENT"
FUNCTION = %S_OK
END FUNCTION
FUNCTION Disconnect ALIAS "Disconnect" ( Sender AS IUnknown, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "Disconnect", %MB_OK, "EVENT"
END FUNCTION
zu deklarieren.
Das komplette Beispielprogramm:
Die Exe:
Code:
#DIM ALL
#REGISTER NONE
#COMPILE EXE
#TOOLS OFF
#INCLUDE "win32api.inc"
#INCLUDE "COMEvent.inc"
FUNCTION InfoMessage ALIAS "InfoMessage" ( Sender AS IUnknown, pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "InfoMessage", %MB_OK, "EVENT"
END FUNCTION
FUNCTION BeginTransComplete ALIAS "BeginTransComplete" ( Sender AS IUnknown, TransactionLevel AS LONG, pError AS DWORD, adStatus AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "BeginTransComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION RollbackTransComplete ALIAS "RollbackTransComplete" ( Sender AS IUnknown, BYVAL pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "RollbackTransComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION CommitTransComplete ALIAS "CommitTransComplete" ( Sender AS IUnknown, BYVAL pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "CommitTransComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION WillExecute ALIAS "WillExecute" ( Sender AS IUnknown, Source AS DWORD, CursorType AS DWORD, LockType AS DWORD, Options AS DWORD, adStatus AS DWORD, _
pCommand AS DWORD, pRecordset AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "WillExecute", %MB_OK, "EVENT"
END FUNCTION
FUNCTION ExecuteComplete ALIAS "ExecuteComplete" ( Sender AS IUnknown, RecordsAffected AS DWORD, pError AS DWORD, adStatus AS DWORD, pCommand AS DWORD, _
pRecordset AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "ExecuteComplete", %MB_OK, "EVENT"
END FUNCTION
FUNCTION WillConnect ALIAS "WillConnect" ( Sender AS IUnknown, ConnectionString AS STRING, UserID AS DWORD, Password AS DWORD, Options AS DWORD, _
adStatus AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "WillConnect" + $CRLF + $CRLF + ACODE$(ConnectionString), %MB_OK, "EVENT"
END FUNCTION
FUNCTION ConnectComplete ALIAS "ConnectComplete" ( Sender AS IUnknown, pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "ConnectComplete", %MB_OK, "EVENT"
FUNCTION = %S_OK
END FUNCTION
FUNCTION Disconnect ALIAS "Disconnect" ( Sender AS IUnknown, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "Disconnect", %MB_OK, "EVENT"
END FUNCTION
SUB UnPackDSN
DIM s AS STRING
DIM i AS DWORD
DIM f AS DWORD
f = FREEFILE
IF DIR$("dmo.dsn") <> "" THEN EXIT SUB
FOR i = 1 TO DATACOUNT
s = s + READ$(i) + $CRLF
NEXT
OPEN "dmo.dsn" FOR OUTPUT AS f
PRINT #f, s
CLOSE #f
EXIT SUB
DATA "[ODBC]"
DATA "DRIVER=Microsoft Text Driver (*.txt; *.csv)"
DATA "UID=admin"
DATA "UserCommitSync=Yes"
DATA "Threads=3"
DATA "SafeTransactions=0"
DATA "PageTimeout=5"
DATA "MaxScanRows=25"
DATA "MaxBufferSize=2048"
DATA "FIL=text"
DATA "Extensions=txt,csv,tab,asc"
DATA "DriverId=27"
DATA "DefaultDir=\"
END SUB
FUNCTION PBMAIN
DIM foo(8) AS DWORD
DIM myObj AS DISPATCH
DIM vObj AS VARIANT
DIM vntStr AS VARIANT
DIM vntVar AS VARIANT
foo(0) = CODEPTR(InfoMessage)
foo(1) = CODEPTR(BeginTransComplete)
foo(2) = CODEPTR(RollbackTransComplete)
foo(3) = CODEPTR(CommitTransComplete)
foo(4) = CODEPTR(WillExecute)
foo(5) = CODEPTR(ExecuteComplete)
foo(6) = CODEPTR(WillConnect)
foo(7) = CODEPTR(ConnectComplete)
foo(8) = CODEPTR(Disconnect)
CreateWithEvents "ADODB.Connection", foo(), vObj
'CreateDispEvents "ADODB.Connection", vObj
IF VARIANTVT(vObj) <> %VT_DISPATCH THEN EXIT FUNCTION
SET myObj = vObj
vntstr = "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=""DefaultDir=c:\;" + _
"Driver={Microsoft Text Driver (*.txt;*.csv)};DriverId=27;" + _
"Extensions=txt,csv,tab,asc;FIL=text;FILEDSN=dmo.dsn;MaxBufferSize=2048;MaxScanRows=25;" + _
"PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;""
MSGBOX "Set Connection String"
OBJECT LET myObj.ConnectionString = vntStr
MSGBOX "Open Connection"
OBJECT CALL myObj.Open
MSGBOX "Get Connection State"
OBJECT GET myObj.State TO vntvar
END FUNCTION
Die COMEvent.Inc
Code:
#IF NOT %DEF(%WS_VISIBLE)
#INCLUDE "Win32Api.Inc"
#ENDIF
#IF NOT %DEF(%W_COMEVENTINC)
%W_COMEVENTINC = 1
'**************************************************************************
%CLSCTX_INPROC_SERVER = 1
%CLSCTX_INPROC_HANDLER = 2
%CLSCTX_LOCAL_SERVER = 4
%CLSCTX_REMOTE_SERVER = 16
%CLSCTX_NO_CODE_DOWNLOAD = 400
%CLSCTX_NO_FAILURE_LOG = 4000
%CLSCTX_SERVER = %CLSCTX_INPROC_SERVER OR %CLSCTX_LOCAL_SERVER OR %CLSCTX_REMOTE_SERVER
%CLSCTX_ALL = %CLSCTX_INPROC_HANDLER OR %CLSCTX_SERVER
$IID_IUnknown = "{00000000-0000-0000-C000-000000000046}"
$IID_ICPC = "{B196B284-BAB4-101A-B69C-00AA00341D07}"
$IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
TYPE W_Vtbl
fPtr AS DWORD PTR
Count AS DWORD
END TYPE
TYPE W_SupportInfo
Cookie AS DWORD
IID AS GUID
END TYPE
TYPE W_ConnectData
pUnk AS DWORD
Cookie AS DWORD
END TYPE
TYPE IDLDESC DWORD
dwReserved AS DWORD
wIDLFlags AS WORD
END TYPE
UNION TYPEDESCDATA
lptdesc AS DWORD
lpadesc AS DWORD
hreftype AS DWORD
END UNION
TYPE TYPEDESC DWORD
tdd AS TYPEDESCDATA
vt AS WORD
END TYPE
TYPE TYPEATTR
rguid AS GUID
lcid AS DWORD
dwReserved AS DWORD
memidConstructor AS LONG
memidDestructor AS LONG
lpstrSchema AS DWORD
cbSizeInstance AS DWORD
typekind AS DWORD
cFuncs AS WORD
cVars AS WORD
cImplTypes AS WORD
cbSizeVft AS WORD
cbAlignment AS WORD
wTypeFlags AS WORD
wMajorVerNum AS WORD
wMinorVerNum AS WORD
tdescAlias AS TYPEDESC
idldescType AS IDLDESC
END TYPE
TYPE PARAMDESCEX
cBytes AS DWORD
filler AS DWORD
varDefaultValue AS VARIANTAPI
END TYPE
TYPE PARAMDESC DWORD
pparamdescex AS PARAMDESCEX PTR
wParamFlags AS WORD
END TYPE
TYPE ELEMDESC
tdesc AS TYPEDESC
prmdesc AS PARAMDESC
END TYPE
TYPE FUNCDESC
memid AS LONG
lprgscode AS LONG PTR
lprgelemdescParam AS ELEMDESC PTR
funckind AS DWORD
invkind AS DWORD
callconv AS DWORD
cParams AS INTEGER
cParamsOpt AS INTEGER
oVft AS INTEGER
cScodes AS INTEGER
elemdescFunc AS ELEMDESC
wFuncFlags AS WORD
END TYPE
DECLARE FUNCTION OleInitialize LIB "ole32.dll" ALIAS "OleInitialize" (BYVAL pvReserved AS DWORD) AS LONG
DECLARE FUNCTION PInvoke (BYVAL pInterface AS DWORD) AS LONG
DECLARE FUNCTION PInvoke1 (BYVAL pInterface AS DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke2 (BYVAL pInterface AS DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke3 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke4 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PQuery (BYVAL pInterface AS DWORD, GUID, DWORD) AS LONG
GLOBAL W_C() AS W_Vtbl PTR
GLOBAL W_CS() AS W_SupportInfo
GLOBAL W_ISADVISE AS BYTE
FUNCTION W_QueryInterface(pSource AS IUnknown, IID AS GUID, pIUnknown AS IUnknown) AS LONG
LOCAL m AS LONG
LOCAL i AS LONG
LOCAL p AS W_Vtbl PTR
m = UBOUND(W_C())
IF m = -1 THEN
FUNCTION = %E_NOTIMPL
EXIT FUNCTION
END IF
IF W_ISADVISE = 1 THEN
CopyMemory VARPTR(pIUnknown), VARPTR(W_C(m)), 4
@W_C(m).Count = 1
W_CS(m).IID = IID
FUNCTION = %S_OK
EXIT FUNCTION
ELSE
FOR i = 0 TO UBOUND(W_CS())
IF W_CS(i).IID = IID THEN
CopyMemory VARPTR(pIUnknown), VARPTR(W_C(m)), 4
FUNCTION = %S_OK
EXIT FUNCTION
END IF
NEXT
END IF
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_AddRef(pVtbl AS W_Vtbl PTR) AS LONG
LOCAL i AS LONG
FOR i = 0 TO UBOUND(W_C())
IF W_C(i) = pVtbl THEN
INCR @W_C(i).Count
END IF
NEXT
FUNCTION = %S_OK
END FUNCTION
FUNCTION W_Release(pVtbl AS W_Vtbl PTR) AS LONG
LOCAL i AS LONG
FOR i = 0 TO UBOUND(W_C())
IF W_C(i) = pVtbl THEN
DECR @W_C(i).Count
END IF
IF @W_C(i).Count = 0 THEN
CoTaskMemFree W_C(i)
ARRAY DELETE W_C(i)
ARRAY DELETE W_CS(i)
END IF
NEXT
FUNCTION = %S_OK
END FUNCTION
FUNCTION W_GetTypeInfoCount(pctinfo AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_GetTypeInfo(BYVAL itinfo AS DWORD, BYVAL lcid AS LONG, pptinfo AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_GetIDsOfNames(BYREF riid AS GUID, rgszNames AS ASCIIZ, BYVAL cNames AS DWORD, BYVAL lcid AS LONG, rgdispid AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_Invoke(BYREF Sender AS IUnknown, BYVAL dispidMember AS LONG, BYREF riid AS GUID , BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, _
BYREF pdispparams AS DWORD, BYREF pvarResult AS VARIANT, BYREF pexcepinfo AS DWORD, BYREF puArgErr AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
SUB W_CreateInterface(BYVAL nBytes AS LONG, BYREF oInterF AS W_Vtbl PTR)
oInterF = CoTaskMemAlloc(8)
@oInterf.fPtr = CoTaskMemAlloc(nBytes)
END SUB
FUNCTION GetBString(sfooName AS BYTE PTR) AS STRING
LOCAL s AS STRING,si AS STRING
LOCAL i AS LONG
FOR i= 0 TO 255 STEP 2
si = CHR$(@sfooName[i])
IF ASC(Si) > 40 THEN
s = s & si
ELSE
FUNCTION = TRIM$(s)
EXIT FUNCTION
END IF
NEXT
FUNCTION = TRIM$(s)
END FUNCTION
FUNCTION ITypeInfo_GetNames (BYVAL pthis AS DWORD PTR , BYVAL memid AS LONG ,BYVAL rgbstrNames AS DWORD ,BYVAL cMaxNames AS DWORD ,BYREF pcNames AS DWORD) AS LONG
LOCAL HRESULT AS LONG
CALL DWORD @@pthis[7] USING ITypeInfo_GetNames (pthis, memid, rgbstrNames, cMaxNames, pcNames) TO HRESULT
FUNCTION = HRESULT
END FUNCTION
FUNCTION CreateDispEvents(BYVAL sProgID AS STRING, mobj AS VARIANT) AS LONG
DIM clsIDProg AS GUID
DIM IID AS GUID
DIM IID_Connection AS GUID
DIM obj AS DISPATCH
DIM rVal AS DWORD
DIM pUnk AS IUnknown
DIM pDisp AS IDispatch
DIM Container AS W_Vtbl PTR
DIM EnumPoints AS W_Vtbl PTR
DIM ConPoint AS W_Vtbl PTR
DIM ITypeInfo AS W_Vtbl PTR
DIM ITypeLib AS W_Vtbl PTR
DIM EnumCon AS W_Vtbl PTR
DIM n AS DWORD
DIM m AS LONG
DIM i AS DWORD
DIM b AS DWORD
DIM fooName AS BYTE PTR
DIM sfoo AS STRING
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
SET obj = NEW DISPATCH IN sProgiD
IF OBJPTR(obj) = 0 THEN EXIT FUNCTION
SET pUnk = obj
'IConnectionPointContainer
IID = GUID$($IID_ICPC)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(Container))
IF rVal <> %S_OK THEN GOTO CleanUp1
'IEnumConnectionPoints
CALL DWORD @Container.@fPtr[3] USING PInvoke1(Container, BYVAL VARPTR(EnumPoints)) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp2
'Zurücksetzen - reset
CALL DWORD @EnumPoints.@fPtr[5] USING PInvoke(EnumPoints) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp2
'IConnectionPoint
CALL DWORD @EnumPoints.@fPtr[3] USING PInvoke3(EnumPoints, 1, BYVAL VARPTR(ConPoint), i) TO rVal
IF rVal = 0 THEN GOTO CleanUp2
'Release IEnumConnectionPoints
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
CALL DWORD @ConPoint.@fPtr[3] USING PInvoke1(ConPoint, BYVAL VARPTR(IID_Connection)) TO rVal
IID = GUID$($IID_IDispatch)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(pDisp))
IF rVal = %S_OK THEN
rVal = pDisp.GetTypeInfo(0, %NULL, BYVAL VARPTR(ITypeInfo))
IF rVal = %S_OK THEN
CALL DWORD @ItypeInfo.@fPtr[18] USING PInvoke2(ItypeInfo, ITypeLib, i) TO rVal
CALL DWORD @ITypeInfo.@fPtr[2] USING PInvoke(ITypeInfo)
IF rVal = %S_OK THEN
CALL DWORD @ITypeLib.@fPtr[6] USING PInvoke2(ITypeLib, BYVAL VARPTR(IID_Connection), _
BYVAL VARPTR(ITypeInfo)) TO rVal
IF rVal = %S_OK THEN
'GetTypeAttributes
DIM ttyp AS TYPEATTR PTR
DIM tfunc AS FUNCDESC PTR
CALL DWORD @ITypeInfo.@fPtr[3] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
IF rVal = %S_OK THEN
FOR i = 0 TO @ttyp.cFuncs-1
CALL DWORD @ITypeInfo.@fPtr[5] USING PInvoke2(ITypeInfo, BYVAL i, BYVAL VARPTR(tfunc)) TO rVal
CALL DWORD @ITypeInfo.@fPtr[7] USING PInvoke4(ITypeInfo, BYVAL @tfunc.memid, fooname, BYVAL 1, b) TO rVal
sfoo = sfoo & GetBString(fooname) & CHR$(13)
CALL DWORD @ITypeInfo.@fPtr[20] USING PInvoke1(ITypeInfo, BYVAL VARPTR(tfunc)) TO rVal
NEXT
END IF
CALL DWORD @ITypeInfo.@fPtr[19] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
END IF
END IF
END IF
END IF
MSGBOX sfoo
CleanUp2:
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
CleanUp1:
SET obj = NOTHING
END FUNCTION
FUNCTION CreateWithEvents(BYVAL sProgID AS STRING, fooList() AS DWORD, mobj AS VARIANT) AS LONG
DIM clsIDProg AS GUID
DIM IID_IUnknown AS GUID
DIM IID_ICPC AS GUID
DIM IID_IProvideClass AS GUID
DIM IID_IDispatch AS GUID
DIM obj AS DISPATCH
DIM rVal AS DWORD
DIM pUnk AS IUnknown
DIM Container AS W_Vtbl PTR
DIM EnumPoints AS W_Vtbl PTR
DIM ConPoint AS W_Vtbl PTR
DIM EventSink AS W_Vtbl PTR
DIM vT AS W_Vtbl PTR
DIM uPunk AS W_Vtbl PTR
DIM n AS DWORD
DIM m AS LONG
DIM i AS DWORD
DIM dwCookie AS DWORD
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
IID_IUnknown = GUID$("{00000000-0000-0000-C000-000000000046}")
IID_ICPC = GUID$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
IID_IDispatch = GUID$("{00020400-0000-0000-C000-000000000046}")
'OleInitialize BYVAL 0
'rval = CoCreateInstance(clsIDProg, BYVAL 0, %CLSCTX_ALL, IID_IDispatch, BYVAL VARPTR(obj))
'IF rVal <> %S_OK THEN EXIT FUNCTION
SET obj = NEW DISPATCH IN sProgID
SET pUnk = obj
'IConnectionPointContainer
W_CreateInterface 20, Container
rVal = pUnk.QueryInterface(IID_ICPC, BYVAL VARPTR(Container))
IF rVal <> %S_OK THEN GOTO CleanUp1
'IEnumConnectionPoints
W_CreateInterface 28, EnumPoints
CALL DWORD @Container.@fPtr[3] USING PInvoke1(Container, BYVAL VARPTR(EnumPoints)) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp2
'Zurücksetzen - reset
CALL DWORD @EnumPoints.@fPtr[5] USING PInvoke(EnumPoints) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp2
'IConnectionPoint
W_CreateInterface 32, ConPoint
CALL DWORD @EnumPoints.@fPtr[3] USING PInvoke3(EnumPoints, 1, BYVAL VARPTR(ConPoint), i) TO rVal
IF rVal = 0 THEN GOTO CleanUp2
'Release IEnumConnectionPoints
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
MSGBOX "OK"
'Create EventSink
EventSink = CoTaskMemAlloc(8)
@EventSink.fPtr = CoTaskMemAlloc(28)
@EventSink.@fPtr[0] = CODEPTR(W_QueryInterface)
@EventSink.@fPtr[1] = CODEPTR(W_AddRef)
@EventSink.@fPtr[2] = CODEPTR(W_Release)
@EventSink.@fPtr[3] = CODEPTR(W_GetTypeInfoCount)
@EventSink.@fPtr[4] = CODEPTR(W_GetTypeInfo)
@EventSink.@fPtr[5] = CODEPTR(W_GetIDsOfNames)
@EventSink.@fPtr[6] = CODEPTR(W_Invoke)
MSGBOX "OK2"
m = UBOUND(W_C()) + 1
REDIM PRESERVE W_C(m)
REDIM PRESERVE W_CS(m)
W_C(m) = CoTaskMemAlloc(8)
@W_C(m).fPtr = CoTaskMemAlloc(12 + (UBOUND(fooList()) * 4))
@W_C(m).@fPtr[0] = CODEPTR(W_QueryInterface)
@W_C(m).@fPtr[1] = CODEPTR(W_AddRef)
@W_C(m).@fPtr[2] = CODEPTR(W_Release)
FOR i = 0 TO UBOUND(fooList())
@W_C(m).@fPtr[i + 3] = fooList(i)
NEXT
W_ISADVISE = 1
CALL DWORD @ConPoint.@fPtr[5] USING PInvoke2(ConPoint, BYVAL EventSink, dwCookie) TO rVal
W_ISADVISE = 0
W_CS(m).Cookie = dwCookie
SET mobj = obj
CleanUp2:
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
CleanUp1:
SET obj = NOTHING
END FUNCTION
'***************************************************************************
#ENDIF
Ja - sind noch alles Baustellen
Dieser Aufruf:
CreateWithEvents "ADODB.Connection", foo(), vObj
Connectet den ConnectionPoint und Events werden gefeuert.
Dieser Aufruf:
CreateDispEvents "ADODB.Connection", vObj
Listet die Events in VTable-Order auf, die das Objekt überhaupt unterstützt.
Die Absicht ist immer noch:
PB supportet Events, ohne Software Dritter. Wenn wir ein Objekt deklarieren soll die Inc automatisch ein Connectioninterface mit den von uns definierten Event-Funktionen organisieren.
Wenn wir wissen, wie die Event-Funktionen heißen, und wir haben unsere Eventfunktonen exportiert, so
können wir mit dem Eventnamen unser Programm checken und wissen was unterstützt werden soll und was nicht. Wir können die VTable aber nicht leer lassen. D.h: Es geht nicht, dass wir für einen Funktion die wir nicht betätigen eine 0 in die VTable eintragen. Das crashed!
Also benötigen wir eine art "Dummy" Funktion deren Pointer in die VTable eingetragen wird für jede Funktion, die wir nicht unterstützen. Das ist ein Problem, weil die Signatur der Funktion sich ja den Events anpassen muss.
Tatsächlich erweisen sich die "nicht unterstützten" Events, die wir einfach nicht definieren wollen, weil wir sie nicht benötigen, als General protection fault Produzent Nr 1! Eigentlich klar: Der Server hat ja nichts anderes als einen Pointer, auf dem er seine Params hin postet. Das ist eine Funktion die nach _stdCall die Parameter von rechts nach links vom Stack holt, den Schluss bildet die Rücksprungaddresse. Das bedeutet: Die Event-Funktion muss exakt der Signatur entsprechen, die der Server erwartet. Es geht auch nicht irgendwas mit Optional. Auch die Aufrufkonvention kann nicht geändert werden, sie muss _stdCall sein.
Das ESB-Register der CPU, die die Rücksprungaddresse hat, nützt auch nichts.
Je nach Anzahl der zu unterstützenden Parameter eine dummy-Foo schreiben? in der Form:
Code:
FUNCTION W_EventDummy (sender AS IUnknown) AS LONG
END FUNCTION
FUNCTION W_EventDummy1 (sender AS IUnknown, A AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy2 (sender AS IUnknown, A AS DWORD, B AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy3 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy4 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy5 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy6 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy7 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy8 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy9 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD, I AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy10 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD, I AS DWORD, J AS DWORD) AS LONG
END FUNCTION
das funktioniert hervorragend, aber erscheint mir nicht als das Gelbe vom Ei zu sein.
Hier ist guter Rat teuer
Bearbeitet von Lordchen (17:36 23/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Ja
Du musst Das alles gar nicht programmieren, da wir das alles via einer Include-Datei:
COMEvent.inc managen Das ist keine gute Nachricht. Weil: Wenn uns etwas schief läuft,
solltest Du schon wissen, warum!
Du solltest nicht in die COMEvent.Inc eingreifen.
Ich stelle nicht die komplette Inc dar, da Dich wahrscheinlich eh nur ein Fakt interessiert:
Ich habe da eine COM-Komponente, binde sie ein und gut ist. Fortan kannst du einfache Funktionen schreiben, die die Events dieser Komponente aufnehmen, als einfache PB-Funktionnen mit dem DLL-Zusatz: Alias und Export. Die Signatur muss genau dem Event entsprechen - sonst: GPF.
Die üblichen Dispatch-Methoden wie Call, Set, Get, Let musst Du mit dem OBJECT ausmachen.
COMEvent beschäftigt sich nur mit dem Postings zwischen Server und Client.
Wann gibt es die komplette: COMEvent.Inc?
Wenn dieser Kurs beendet wird
Und ich stehe vor einem Problem: Wie weißt Du wie die genaue Signatur eines Events (oder andere Methode und Eigenschaft) aussieht?
VB hat das mit Intellisence hervorragend gelöst. Ich möchte (via einer Inc!!!!) das nicht in PB einführen. Aber vielleicht ist einer unserer Tools-Doktörchen bereit hier mal Hand anzulegen?
Wäre ein sinnvoller Job Anstatt sich immer mit PB herum zu ärgern.
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
Bearbeitet von Lordchen (21:16 23/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Es ist soweit
Bis auf einen kleinen Schönheitsfehler (wurde oben gesagt) ist es mit unserer COMEvent.Inc möglich, dass Du eine ActiveX-Komponente in dein PB-Programm einbindest und automatisch mit Events verknüpft wird, die Du frei definieren kannst (und natürlich zu dem Objekt passen!).
Im Gegensatz zu einer reinen VTable-Deklaration der Event-Funktionen, die sowohl in der Reihenfolge stimmen müssen als auch zwingend als Funktion (wenn auch leer) vorhanden sein müssen, geht unsere CreateDispEvent() der COMEvent.Inc den Weg der Automation über IDispatch.
Dies bedingt natürlich, dass Deine ActiveX-Komponente auch IDispatch unterstützt (muss sie nicht unbedingt, da sie auch via VTable Events senden kann, aber dafür haben wir ja die CreateVTableEvent() natürlich mit viel weniger Komfort).
Noch ein Erfordernis ist für die CreateDispEvent() Funktion erforderlich: Diese Eventfunktionen müssen exportiert werden! Also mit Alias versehen und EXPORT Schlüsselwort versehen. Es ist erforderlich, dass diese Funktionen der genauen Signatur entsprechen, die das von der ActiveX-Komponente gefeuerte Event verlangt. Will sie drei Parameter, müssen drei DWORD-Parameter plus IUnknown in der Funktion vorhanden sein, sonst crash!
In dem nachfolgenden Programm (nein, es ist wirklich nicht mehr und nicht weniger) connection wir ADODB.Connection und wollen daraus nur zwei Events wissen: WillConnection und wann die Connection wieder gelöst wird. Die COMEvent.Inc muss natürlich includet werden
Code:
#DIM ALL
#REGISTER NONE
#COMPILE EXE
#INCLUDE "win32api.inc"
#INCLUDE "COMEvent.inc"
FUNCTION WillConnect ALIAS "WillConnect" ( Sender AS IUnknown, ConnectionString AS STRING, UserID AS DWORD, Password AS DWORD, Options AS DWORD, _
adStatus AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "WillConnect" + $CRLF + $CRLF + ACODE$(ConnectionString), %MB_OK, "EVENT"
END FUNCTION
FUNCTION ConnectComplete ALIAS "ConnectComplete" ( Sender AS IUnknown, pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "ConnectComplete", %MB_OK, "EVENT"
FUNCTION = %S_OK
END FUNCTION
FUNCTION PBMAIN
DIM myObj AS DISPATCH
DIM vObj AS VARIANT
DIM vntStr AS VARIANT
DIM vntVar AS VARIANT
CreateDispEvents "ADODB.Connection", vObj 'well done ...... ;)
IF VARIANTVT(vObj) <> %VT_DISPATCH THEN EXIT FUNCTION
SET myObj = vObj
vntstr = "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=""DefaultDir=c:\;" + _
"Driver={Microsoft Text Driver (*.txt;*.csv)};DriverId=27;" + _
"Extensions=txt,csv,tab,asc;FIL=text;FILEDSN=dmo.dsn;MaxBufferSize=2048;MaxScanRows=25;" + _
"PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;""
OBJECT LET myObj.ConnectionString = vntStr
MSGBOX "Open Connection"
OBJECT CALL myObj.Open
MSGBOX "Get Connection State"
OBJECT GET myObj.State TO vntvar
END FUNCTION
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Code:
#IF NOT %DEF(%WS_VISIBLE)
#INCLUDE "Win32Api.Inc"
#ENDIF
#IF NOT %DEF(%W_COMEVENTINC)
%W_COMEVENTINC = 1
'**************************************************************************
%CLSCTX_INPROC_SERVER = 1
%CLSCTX_INPROC_HANDLER = 2
%CLSCTX_LOCAL_SERVER = 4
%CLSCTX_REMOTE_SERVER = 16
%CLSCTX_NO_CODE_DOWNLOAD = 400
%CLSCTX_NO_FAILURE_LOG = 4000
%CLSCTX_SERVER = %CLSCTX_INPROC_SERVER OR %CLSCTX_LOCAL_SERVER OR %CLSCTX_REMOTE_SERVER
%CLSCTX_ALL = %CLSCTX_INPROC_HANDLER OR %CLSCTX_SERVER
$IID_IUnknown = "{00000000-0000-0000-C000-000000000046}"
$IID_ICPC = "{B196B284-BAB4-101A-B69C-00AA00341D07}"
$IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
TYPE W_Vtbl
fPtr AS DWORD PTR
Count AS DWORD
END TYPE
TYPE W_SupportInfo
Cookie AS DWORD
IID AS GUID
END TYPE
TYPE W_ConnectData
pUnk AS DWORD
Cookie AS DWORD
END TYPE
TYPE IDLDESC DWORD
dwReserved AS DWORD
wIDLFlags AS WORD
END TYPE
UNION TYPEDESCDATA
lptdesc AS DWORD
lpadesc AS DWORD
hreftype AS DWORD
END UNION
TYPE TYPEDESC DWORD
tdd AS TYPEDESCDATA
vt AS WORD
END TYPE
TYPE TYPEATTR
rguid AS GUID
lcid AS DWORD
dwReserved AS DWORD
memidConstructor AS LONG
memidDestructor AS LONG
lpstrSchema AS DWORD
cbSizeInstance AS DWORD
typekind AS DWORD
cFuncs AS WORD
cVars AS WORD
cImplTypes AS WORD
cbSizeVft AS WORD
cbAlignment AS WORD
wTypeFlags AS WORD
wMajorVerNum AS WORD
wMinorVerNum AS WORD
tdescAlias AS TYPEDESC
idldescType AS IDLDESC
END TYPE
TYPE PARAMDESCEX
cBytes AS DWORD
filler AS DWORD
varDefaultValue AS VARIANTAPI
END TYPE
TYPE PARAMDESC DWORD
pparamdescex AS PARAMDESCEX PTR
wParamFlags AS WORD
END TYPE
TYPE ELEMDESC
tdesc AS TYPEDESC
prmdesc AS PARAMDESC
END TYPE
TYPE FUNCDESC
memid AS LONG
lprgscode AS LONG PTR
lprgelemdescParam AS ELEMDESC PTR
funckind AS DWORD
invkind AS DWORD
callconv AS DWORD
cParams AS INTEGER
cParamsOpt AS INTEGER
oVft AS INTEGER
cScodes AS INTEGER
elemdescFunc AS ELEMDESC
wFuncFlags AS WORD
END TYPE
DECLARE FUNCTION PInvoke (BYVAL pInterface AS DWORD) AS LONG
DECLARE FUNCTION PInvoke1 (BYVAL pInterface AS DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke2 (BYVAL pInterface AS DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke3 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke4 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD, DWORD) AS LONG
GLOBAL W_C() AS W_Vtbl PTR
GLOBAL W_CS() AS W_SupportInfo
GLOBAL W_ISADVISE AS BYTE
FUNCTION W_QueryInterface(pSource AS IUnknown, IID AS GUID, pIUnknown AS IUnknown) AS LONG
LOCAL m AS LONG
LOCAL i AS LONG
LOCAL p AS W_Vtbl PTR
m = UBOUND(W_C())
IF m = -1 THEN
FUNCTION = %E_NOTIMPL
EXIT FUNCTION
END IF
IF W_ISADVISE = 1 THEN
CopyMemory VARPTR(pIUnknown), VARPTR(W_C(m)), 4
@W_C(m).Count = 1
W_CS(m).IID = IID
FUNCTION = %S_OK
EXIT FUNCTION
ELSE
FOR i = 0 TO UBOUND(W_CS())
IF W_CS(i).IID = IID THEN
CopyMemory VARPTR(pIUnknown), VARPTR(W_C(m)), 4
FUNCTION = %S_OK
EXIT FUNCTION
END IF
NEXT
END IF
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_AddRef(pVtbl AS W_Vtbl PTR) AS LONG
LOCAL i AS LONG
FOR i = 0 TO UBOUND(W_C())
IF W_C(i) = pVtbl THEN
INCR @W_C(i).Count
END IF
NEXT
FUNCTION = %S_OK
END FUNCTION
FUNCTION W_Release(pVtbl AS W_Vtbl PTR) AS LONG
LOCAL i AS LONG
FOR i = 0 TO UBOUND(W_C())
IF W_C(i) = pVtbl THEN
DECR @W_C(i).Count
END IF
IF @W_C(i).Count = 0 THEN
CoTaskMemFree W_C(i)
ARRAY DELETE W_C(i)
ARRAY DELETE W_CS(i)
END IF
NEXT
FUNCTION = %S_OK
END FUNCTION
FUNCTION W_GetTypeInfoCount(pctinfo AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_GetTypeInfo(BYVAL itinfo AS DWORD, BYVAL lcid AS LONG, pptinfo AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_GetIDsOfNames(BYREF riid AS GUID, rgszNames AS ASCIIZ, BYVAL cNames AS DWORD, BYVAL lcid AS LONG, rgdispid AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_Invoke(BYREF Sender AS IUnknown, BYVAL dispidMember AS LONG, BYREF riid AS GUID , BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, _
BYREF pdispparams AS DWORD, BYREF pvarResult AS VARIANT, BYREF pexcepinfo AS DWORD, BYREF puArgErr AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION GetBString(sfooName AS BYTE PTR) AS STRING
LOCAL s AS STRING,si AS STRING
LOCAL i AS LONG
FOR i= 0 TO 255 STEP 2
si = CHR$(@sfooName[i])
IF ASC(Si) > 40 THEN
s = s & si
ELSE
FUNCTION = TRIM$(s)
EXIT FUNCTION
END IF
NEXT
FUNCTION = TRIM$(s)
END FUNCTION
SUB W_CreateEventSink(BYVAL pCp AS W_Vtbl PTR, fooList() AS DWORD)
DIM EventSink AS W_Vtbl PTR
DIM m AS LONG, i AS LONG
DIM dwCookie AS DWORD
DIM rVal AS DWORD
'Create EventSink
EventSink = CoTaskMemAlloc(8)
@EventSink.fPtr = CoTaskMemAlloc(28)
@EventSink.@fPtr[0] = CODEPTR(W_QueryInterface)
@EventSink.@fPtr[1] = CODEPTR(W_AddRef)
@EventSink.@fPtr[2] = CODEPTR(W_Release)
@EventSink.@fPtr[3] = CODEPTR(W_GetTypeInfoCount)
@EventSink.@fPtr[4] = CODEPTR(W_GetTypeInfo)
@EventSink.@fPtr[5] = CODEPTR(W_GetIDsOfNames)
@EventSink.@fPtr[6] = CODEPTR(W_Invoke)
m = UBOUND(W_C()) + 1
REDIM PRESERVE W_C(m)
REDIM PRESERVE W_CS(m)
W_C(m) = CoTaskMemAlloc(8)
@W_C(m).fPtr = CoTaskMemAlloc(12 + (UBOUND(fooList()) * 4))
@W_C(m).@fPtr[0] = CODEPTR(W_QueryInterface)
@W_C(m).@fPtr[1] = CODEPTR(W_AddRef)
@W_C(m).@fPtr[2] = CODEPTR(W_Release)
FOR i = 0 TO UBOUND(fooList())
@W_C(m).@fPtr[i + 3] = fooList(i)
NEXT
W_ISADVISE = 1
CALL DWORD @pCp.@fPtr[5] USING PInvoke2(pCp, BYVAL EventSink, dwCookie) TO rVal
W_ISADVISE = 0
W_CS(m).Cookie = dwCookie
END SUB
FUNCTION W_GetConnectionPoint(vpUnk AS VARIANT) AS DWORD
DIM IID AS GUID
DIM Container AS W_Vtbl PTR
DIM EnumPoints AS W_Vtbl PTR
DIM ConnPoint AS W_Vtbl PTR
DIM rVal AS DWORD
DIM i AS LONG
DIM pUnk AS IUnknown
SET pUnk = vpUnk
'IConnectionPointContainer
IID = GUID$($IID_ICPC)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(Container))
IF rVal <> %S_OK THEN EXIT FUNCTION
'IEnumConnectionPoints
CALL DWORD @Container.@fPtr[3] USING PInvoke1(Container, BYVAL VARPTR(EnumPoints)) TO rVal
IF rVal <> %S_OK THEN
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
FUNCTION = 1
EXIT FUNCTION
END IF
'Zurücksetzen - reset
CALL DWORD @EnumPoints.@fPtr[5] USING PInvoke(EnumPoints) TO rVal
IF rVal <> %S_OK THEN
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
FUNCTION = 2
EXIT FUNCTION
END IF
'IConnectionPoint
CALL DWORD @EnumPoints.@fPtr[3] USING PInvoke3(EnumPoints, 1, BYVAL VARPTR(ConnPoint), i) TO rVal
IF rVal = 0 THEN
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
FUNCTION = 3
EXIT FUNCTION
END IF
'Release IEnumConnectionPoints
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
FUNCTION = ConnPoint
END FUNCTION
FUNCTION W_EventDummy (sender AS IUnknown) AS LONG
END FUNCTION
FUNCTION W_EventDummy1 (sender AS IUnknown, A AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy2 (sender AS IUnknown, A AS DWORD, B AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy3 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy4 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy5 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy6 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy7 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy8 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy9 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD, I AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy10 (sender AS IUnknown, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD, I AS DWORD, J AS DWORD) AS LONG
END FUNCTION
FUNCTION CreateDispEvents(BYVAL sProgID AS STRING, mobj AS VARIANT) AS LONG
DIM clsIDProg AS GUID
DIM IID AS GUID
DIM IID_Connection AS GUID
DIM obj AS DISPATCH
DIM rVal AS DWORD
DIM pUnk AS IUnknown
DIM vUnk AS VARIANT
DIM pDisp AS IDispatch
DIM ITypeInfo AS W_Vtbl PTR
DIM ITypeLib AS W_Vtbl PTR
DIM ConPoint AS W_Vtbl PTR
DIM i AS DWORD
DIM b AS DWORD
DIM count AS DWORD
DIM nAdr AS DWORD
DIM fooName AS BYTE PTR
DIM fooList() AS DWORD
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
SET obj = NEW DISPATCH IN sProgiD
IF OBJPTR(obj) = 0 THEN EXIT FUNCTION
SET vUnk = Obj
ConPoint = W_GetConnectionPoint(vUnk)
CALL DWORD @ConPoint.@fPtr[3] USING PInvoke1(ConPoint, BYVAL VARPTR(IID_Connection)) TO rVal
SET pUnk = obj
IID = GUID$($IID_IDispatch)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(pDisp))
IF rVal = %S_OK THEN
rVal = pDisp.GetTypeInfo(0, %NULL, BYVAL VARPTR(ITypeInfo))
IF rVal = %S_OK THEN
CALL DWORD @ItypeInfo.@fPtr[18] USING PInvoke2(ItypeInfo, ITypeLib, i) TO rVal
CALL DWORD @ITypeInfo.@fPtr[2] USING PInvoke(ITypeInfo)
IF rVal = %S_OK THEN
CALL DWORD @ITypeLib.@fPtr[6] USING PInvoke2(ITypeLib, BYVAL VARPTR(IID_Connection), _
BYVAL VARPTR(ITypeInfo)) TO rVal
IF rVal = %S_OK THEN
'GetTypeAttributes
DIM ttyp AS TYPEATTR PTR
DIM tfunc AS FUNCDESC PTR
CALL DWORD @ITypeInfo.@fPtr[3] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
IF rVal = %S_OK THEN
FOR i = 0 TO @ttyp.cFuncs-1
CALL DWORD @ITypeInfo.@fPtr[5] USING PInvoke2(ITypeInfo, BYVAL i, BYVAL VARPTR(tfunc)) TO rVal
CALL DWORD @ITypeInfo.@fPtr[7] USING PInvoke4(ITypeInfo, BYVAL @tfunc.memid, fooname, BYVAL 1, b) TO rVal
REDIM PRESERVE fooList(i)
count = @tfunc.cParams
IF count > 10 THEN
MSGBOX "Benötige W_EventDummy Erweiterung auf: " & STR$(count),,"ACHTUNG COMEvent.Inc muss angepasst werden!"
EXIT FUNCTION
END IF
nAdr = GetProcAddress(GetModuleHandle(""), GetBString(fooName))
IF nAdr <> 0 THEN
fooList(i) = nAdr
ELSEIF nAdr = 0 THEN
SELECT CASE count
CASE 0 : fooList(i)=CODEPTR(W_EventDummy)
CASE 1 : fooList(i)=CODEPTR(W_EventDummy1)
CASE 2 : fooList(i)=CODEPTR(W_EventDummy2)
CASE 3 : fooList(i)=CODEPTR(W_EventDummy3)
CASE 4 : fooList(i)=CODEPTR(W_EventDummy4)
CASE 5 : fooList(i)=CODEPTR(W_EventDummy5)
CASE 6 : fooList(i)=CODEPTR(W_EventDummy6)
CASE 7 : fooList(i)=CODEPTR(W_EventDummy7)
CASE 8 : fooList(i)=CODEPTR(W_EventDummy8)
CASE 9 : fooList(i)=CODEPTR(W_EventDummy9)
CASE 10 : fooList(i)=CODEPTR(W_EventDummy10)
END SELECT
END IF
'sfoo = sfoo & GetBString(fooname) & CHR$(13)
CALL DWORD @ITypeInfo.@fPtr[20] USING PInvoke1(ITypeInfo, BYVAL VARPTR(tfunc)) TO rVal
NEXT
W_CreateEventSink W_GetConnectionPoint(vUnk) , fooList()
END IF
CALL DWORD @ITypeInfo.@fPtr[19] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
END IF
END IF
END IF
END IF
SET mobj = obj
END FUNCTION
FUNCTION CreateVTableEvents(BYVAL sProgID AS STRING, fooList() AS DWORD, mobj AS VARIANT) AS LONG
DIM clsIDProg AS GUID
DIM obj AS DISPATCH
DIM pUnk AS VARIANT
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
SET obj = NEW DISPATCH IN sProgID
SET pUnk = obj
W_CreateEventSink W_GetConnectionPoint(pUnk) , fooList()
SET mobj = obj
END FUNCTION
'***************************************************************************
#ENDIF
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Wenn man nur eine Komponente automatisiert, dürfte es kaum ein Problem darstellen. Die Rede ist: Von gleichnamigen Funktionen. Wenn aber zwei Komponente da sind, ist es nicht ausgeschlossen, dass beide Komponente die gleichen Events haben, zB. Click(). Was tun? sprach Zeus.
Hmmm .... was VB auch tut
Wir erweitern CreateDispEvent einfach um einen Parameter mit Foo-Suffix und halten uns einfach daran, dass ab sofort alle veröffentlicten Event-Funktionen um diesen Suffix erweitert werden.
Das sieht dann so aus:
Code:
#DIM ALL
#REGISTER NONE
#COMPILE EXE
#INCLUDE "win32api.inc"
#INCLUDE "COMEvent.inc"
FUNCTION myObj_WillConnect ALIAS "myObj_WillConnect" ( Sender AS IUnknown, ConnectionString AS STRING, UserID AS DWORD, Password AS DWORD, Options AS DWORD, _
adStatus AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "WillConnect" + $CRLF + $CRLF + ACODE$(ConnectionString), %MB_OK, "EVENT"
END FUNCTION
FUNCTION myObj_ConnectComplete ALIAS "myObj_ConnectComplete" ( Sender AS IUnknown, pError AS DWORD, EventStatusEnum AS DWORD, pConnection AS DWORD) EXPORT AS LONG
MSGBOX "ConnectComplete", %MB_OK, "EVENT"
FUNCTION = %S_OK
END FUNCTION
FUNCTION PBMAIN
DIM myObj AS DISPATCH
DIM vObj AS VARIANT
DIM vntStr AS VARIANT
DIM vntVar AS VARIANT
CreateDispEvents "ADODB.Connection", vObj, "myObj"
IF VARIANTVT(vObj) <> %VT_DISPATCH THEN EXIT FUNCTION
SET myObj = vObj
vntstr = "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=""DefaultDir=c:\;" + _
"Driver={Microsoft Text Driver (*.txt;*.csv)};DriverId=27;" + _
"Extensions=txt,csv,tab,asc;FIL=text;FILEDSN=dmo.dsn;MaxBufferSize=2048;MaxScanRows=25;" + _
"PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;""
OBJECT LET myObj.ConnectionString = vntStr
MSGBOX "Open Connection"
OBJECT CALL myObj.Open
MSGBOX "Get Connection State"
OBJECT GET myObj.State TO vntvar
END FUNCTION
und die CreateDispEvents( ... )
Code:
FUNCTION CreateDispEvents(BYVAL sProgID AS STRING, mobj AS VARIANT, BYVAL sFooPrefix AS STRING) AS LONG
DIM clsIDProg AS GUID
DIM IID AS GUID
DIM IID_Connection AS GUID
DIM obj AS DISPATCH
DIM rVal AS DWORD
DIM pUnk AS IUnknown
DIM vUnk AS VARIANT
DIM pDisp AS IDispatch
DIM ITypeInfo AS W_Vtbl PTR
DIM ITypeLib AS W_Vtbl PTR
DIM ConPoint AS W_Vtbl PTR
DIM i AS DWORD
DIM b AS DWORD
DIM count AS DWORD
DIM nAdr AS DWORD
DIM fooName AS BYTE PTR
DIM fooList() AS DWORD
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
SET obj = NEW DISPATCH IN sProgiD
IF OBJPTR(obj) = 0 THEN EXIT FUNCTION
SET vUnk = Obj
ConPoint = W_GetConnectionPoint(vUnk)
IF ConPoint = 0 THEN EXIT FUNCTION
CALL DWORD @ConPoint.@fPtr[3] USING PInvoke1(ConPoint, BYVAL VARPTR(IID_Connection)) TO rVal
SET pUnk = obj
IID = GUID$($IID_IDispatch)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(pDisp))
IF rVal = %S_OK THEN
rVal = pDisp.GetTypeInfo(0, %NULL, BYVAL VARPTR(ITypeInfo))
IF rVal = %S_OK THEN
CALL DWORD @ItypeInfo.@fPtr[18] USING PInvoke2(ItypeInfo, ITypeLib, i) TO rVal
CALL DWORD @ITypeInfo.@fPtr[2] USING PInvoke(ITypeInfo)
IF rVal = %S_OK THEN
CALL DWORD @ITypeLib.@fPtr[6] USING PInvoke2(ITypeLib, BYVAL VARPTR(IID_Connection), _
BYVAL VARPTR(ITypeInfo)) TO rVal
IF rVal = %S_OK THEN
'GetTypeAttributes
DIM ttyp AS TYPEATTR PTR
DIM tfunc AS FUNCDESC PTR
CALL DWORD @ITypeInfo.@fPtr[3] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
IF rVal = %S_OK THEN
FOR i = 0 TO @ttyp.cFuncs-1
CALL DWORD @ITypeInfo.@fPtr[5] USING PInvoke2(ITypeInfo, BYVAL i, BYVAL VARPTR(tfunc)) TO rVal
CALL DWORD @ITypeInfo.@fPtr[7] USING PInvoke4(ITypeInfo, BYVAL @tfunc.memid, fooname, BYVAL 1, b) TO rVal
REDIM PRESERVE fooList(i)
count = @tfunc.cParams
IF count > 10 THEN
MSGBOX "Benötige W_EventDummy Erweiterung auf: " & STR$(count),,"ACHTUNG COMEvent.Inc muss angepasst werden!"
EXIT FUNCTION
END IF
nAdr = GetProcAddress(GetModuleHandle(""), sFooPrefix& "_" & GetBString(fooName))
IF nAdr <> 0 THEN
fooList(i) = nAdr
ELSEIF nAdr = 0 THEN
SELECT CASE count
CASE 0 : fooList(i)=CODEPTR(W_EventDummy)
CASE 1 : fooList(i)=CODEPTR(W_EventDummy1)
CASE 2 : fooList(i)=CODEPTR(W_EventDummy2)
CASE 3 : fooList(i)=CODEPTR(W_EventDummy3)
CASE 4 : fooList(i)=CODEPTR(W_EventDummy4)
CASE 5 : fooList(i)=CODEPTR(W_EventDummy5)
CASE 6 : fooList(i)=CODEPTR(W_EventDummy6)
CASE 7 : fooList(i)=CODEPTR(W_EventDummy7)
CASE 8 : fooList(i)=CODEPTR(W_EventDummy8)
CASE 9 : fooList(i)=CODEPTR(W_EventDummy9)
CASE 10 : fooList(i)=CODEPTR(W_EventDummy10)
END SELECT
END IF
'sfoo = sfoo & GetBString(fooname) & CHR$(13)
CALL DWORD @ITypeInfo.@fPtr[20] USING PInvoke1(ITypeInfo, BYVAL VARPTR(tfunc)) TO rVal
NEXT
W_CreateEventSink W_GetConnectionPoint(vUnk) , fooList()
END IF
CALL DWORD @ITypeInfo.@fPtr[19] USING PInvoke1(ITypeInfo, BYVAL VARPTR(ttyp)) TO rVal
END IF
END IF
END IF
END IF
SET mobj = obj
END FUNCTION
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
Bearbeitet von Lordchen (15:40 25/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Wenn die ActiveX-Komponente ein ActiveX-Control ist, und vor allem mit graphischer Benutzeroberfläche, so hat man ein Problem vor allem dann, wenn das Teil keine hWnd-Eigenschaft offen legt. Das MSFlexgrid-Control ist so ein Vertreter.
Deshalb wurde für alle Controls: CreateControl() in die COMEvent.Inc aufgenommen. Diese Funkton erwartet die ProgID des Controls (bzw. Klassenbezeichnung wie: "MSFlexGridLib.MSFlexGrid"), sowie den Handle des Windows, auf dem es platziert werden soll.
Die Inc wurde um diese Funktionen erweitert:
Code:
DECLARE FUNCTION AtlAxCreateControl LIB "ATL.dll" _
ALIAS "AtlAxCreateControl" ( _
BYVAL sProgID AS STRING, _
BYVAL hWnd AS DWORD, _
BYVAL pstream AS DWORD, _
pUnk AS IUnknown) AS LONG
DECLARE FUNCTION AtlAxGetControl LIB "ATL.dll" _
ALIAS "AtlAxGetControl" ( _
BYVAL hWnd AS DWORD, _
pUnk AS IUnknown) AS LONG
Die ATL.dll gehört schon seit längerem zum BS, also keine Sorge man muss nichts mitliefern.
und dann:
Code:
FUNCTION CreateControl(BYVAL sProgID AS STRING, BYVAL hWnd AS DWORD, mobj AS VARIANT) AS LONG
DIM rVal AS DWORD
DIM pUnk AS IUnknown
rval = AtlAxCreateControl(UCODE$(sProgID), hWnd, 0, BYVAL 0)
IF rVal <> %S_OK THEN
FUNCTION = %E_NOTIMPL
EXIT FUNCTION
END IF
rval = AtlAxGetControl(hWnd, BYVAL VARPTR(pUnk))
IF rVal = %S_OK THEN
SET mobj = pUnk
FUNCTION = %S_OK
ELSE
FUNCTION = %E_NOTIMPL
END IF
END FUNCTION
Der Variant mobj ist nach erfolgreicher Ausführung ein Variant vom Typ: %VT_DISPATCH
Den kann ich direkt in eine Dispatch-Objektvariable übernehmen und dann damit die Eigenschaften und Methoden des Teils bedienen:
If VariantVT(mobj) =%VT_DISPATCH Then Set obj = mobj
vVisible = %FALSE
Object Let obj.Visible = vVisible
diesen Variant: mobj kann ich (MOMENTAN) nicht für CreateDispEvents( ... ) verwenden, weil mir diese Funktion ja eine neue Instanz auf das Objekt zurückliefert.
Damit ich aber nicht zwei Funktionen bauen muss: Eine für leere Objektvariable und eine für bereits gefüllte objektvariable, so wird CreateDispEvent etwas geändert, damit auch diese Fälle erfasst werden können.
VORAB aber:
Jetzt geht es wirklich ins Eingemachte. Ich denke das die VTABLE-Events geläufig sind bzw. verständlich?
Weil: Wenn wir damit ein ActiveX-Control via advise connecten, so geht das, fährt aber der Mauszeiger auf das Control macht es peng! Hat man es abgefragt, so merkt man: Ups ...
Die INVOKE-Methode des IDispatch-Interface wird angesprungen!
Ergo muss vorher die EventSink-Funktion noch checken: Welches Interface unterstützt werden soll: Entweder VTABLE für IUnknown - Varianten oder IDispatch für IDispatch-Varianten (wozu wohl alle Controls gehören).
IUnknown-Vtable
QueryInterface
Addref
Release
Click u.s.w
IDispatch-VTable
IUnknown-VTable
IDispatch-VTable (natürlich ohne IUnknown )
Click u.s.w.
was meint: wollen wir wirklich vollständig automatisieren, müssen wir beide Welten vereinen. Diese Frage muss in der CreateEventSink( ... ) der Funktion entschieden und mit zwei verschiedenen VTBles: ein IUnknown oder eine IDispatch je nach Fall eingerichtet werden. Hört sich komplizierter an wie es ist. Wurde doch schon erklärt: Wir können dank Thorstens Dreh mit der UDT JEDES BELIEBIGE Interface anlegen, sofern wir wissen: Welches anzulegen ist: eine IUnknown oder eine IDispatch.
Natürlich liefert diese Information die ITypeLib.
Gretchenfrage: Was kommt genau in Invoke an?
Genau Contröllchen postet UNSERE! IDispatch Implementation und dazu die dispID, also was
für ein Event plus Parameter. Leider auch wieder hier: PB kann nichts vererben, demzufolge müssen wir auch die IDispatch Implementation, anlog IUnknown Implementierung für die mehrfach Verwendung auslegen. Eigentlich genügt, wenn wir dispID und Lage des Funktionspointers auf der VTable in Zusammenhang bringen. Ziehst Du den Mauszeiger da hinein, wird fast ohne unterlass MouseMove gepostet.
Und das wird wieder soviel Verwaltungskram, dass wir doch eine Klasse nehmen
Ja, richtig gelesen! Aus der Sicht von C++ ist eine UDT eine Klasse. Aber deren Member
stets public sind. Also erfolgt mal ein bißchen Umkrempeln der COMEvent.Inc auf einen neuen UDT.
Eine Kleinigkeit wäre da noch: Natürlich könnte ich ITypeInfo in dem UDT saven und in Invoke diese TypenInfo heranziehen und wie "man es halt so macht" dann die Typen und die Funktion "Invoken". Dann
haben wir aber den Nachteil des late Binding - obwohl uns ja die dispID's und die zugehörigen JumpTables ja bekannt sind, da wir die ja unmittelbar (wie es auch sein muss) an das IDispatch-Interface anhängen. Kommt z.B. MouseMove( ... ) so weiß ich, dass ich 28 + (6*4) Bytes zum Offset brauche um den korrekten Jump zu finden. Deswegen würde ich IDispatch insgesamt: E_NOTIMPL lassen - auch Invoke! Aber in Invoke die Funktion dann via Call Dword feuern. Das gibt Early Binding
feel
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
Bearbeitet von Lordchen (18:22 26/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Es war gar nicht so einfach, Contröllchen ein Click-Event zu entlocken! Schuld ist die mühsame Invoke Implemantation die schließlich erst mit DispCallFunc() der Oleaut32.dll zum erwarteten Event führte.
Dabei ist die Disp-Interface genau umgekehrt wie die reine VTABLE Eventsink: Nicht benötigte Funktionen müssen auf 0 gesetzt sein! Dann rührt sich DispCallFunc() auch nicht
So sieht Invoke momentan aus:
Code:
FUNCTION W_Invoke(BYREF Sender AS W_VTABLE PTR, BYVAL dispidMember AS LONG, BYREF riid AS GUID , BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, _
BYREF pdispparams AS DISPPARAMS, BYREF pvarResult AS VARIANT, BYREF pexcepinfo AS DWORD, BYREF puArgErr AS DWORD) AS LONG
DIM pV AS W_VTABLE PTR
DIM i AS LONG
DIM n AS LONG
DIM b AS BYTE
DIM tfunc AS FuncDesc PTR
DIM ttype AS TypeAttr PTR
DIM ncount AS LONG
DIM rVal AS DWORD
DIM nOffset AS DWORD
DIM nParam AS LONG
DIM nRet AS LONG
b=0
FOR i=0 TO UBOUND(W_Instances())
IF W_Instances(i).pUnknown = Sender THEN
b = 1
EXIT FOR
END IF
NEXT
IF b= 0 THEN EXIT FUNCTION
pV = W_Instances(i).pTypeInfo
CALL DWORD @pV.@fPtr[3] USING PInvoke1(pV, BYVAL VARPTR(ttype)) TO rVal
b = 0
FOR n = 0 TO @ttype.cFuncs-1
CALL DWORD @pV.@fPtr[5] USING PInvoke2(pV, BYVAL n, BYVAL VARPTR(tfunc)) TO rVal
IF @tfunc.memID = dispidMember THEN
nParam = @tfunc.cParams
b = 1
EXIT FOR
END IF
CALL DWORD @pV.@fPtr[20] USING PInvoke1(pV, BYVAL VARPTR(tfunc)) TO rVal
NEXT
nOffset = 28 + (n * 4)
rVal = DispCallFunc(Sender, nOffset, %cc_stdcall, %VT_I4, 0, 0&, 0&, BYVAL VARPTR(nRet))
FUNCTION = %E_NOTIMPL
END FUNCTION
Es muss nur noch die Parameterübergabe ausgebaut werden - und dann haben wir es geschafft
OK: Wir müssen eine weitere Abhängigkeit akzeptieren, nämlich zur Oleaut32.dll. Aber auch hier kann ich beruhigen: Ist seit längerem Bestandteil des BS. Ohne die würde die Shell gar nicht funktionieren
Man notiere aber:
Dependencies:
ATL.dll
Oleaut32.dll
Wenn ich aber schon die Oleaut32 binden muss, dann ziehe ich auch noch ein paar Helfer davon an Land, um zB: DispParams aufzulösen
Nun denn, dann weiß ja die Welt, warum Lordchen wieder PowerBASIC proggt
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
Bearbeitet von Lordchen (18:47 27/03/2007)
|
|
|
Lordchen
Champion
Reged: 21:38
Beitrag: 4579
Ort: Baden, Karlsruhe
|
Code:
'****************************************************************************
' Copyright by Visualbasic.AT All Rights reserved!!!!
' Firstdate: 27.03.2007
' Author: Lordchen
' All rights reserved by VB.AT!
' Usage: Du darfst den Code nur verwenden, wenn Du bei VB.AT registriert bist
' Links aus Programmteilen oder die gesamte .INC sind nur zulässig, wenn
' VB.AT damit genannt ist, was meint: Die Quelle muss genannt sein und zwar:
' "www.Visualbasic.At". Jede kommerzielle Nutzung bedarf einer Erlaubnis des
' Authors! Und somit Anfrage an www.Visialbasic.at.
' Jede Publikation dieses Quellcode ohne Nennung des Urhebers verstößt gegen
' internationales Recht
' ***************************************************************************
#IF NOT %DEF(%WS_VISIBLE)
#INCLUDE "Win32Api.Inc"
#ENDIF
#IF NOT %DEF(%W_COMEVENTINC)
%W_COMEVENTINC = 1
'****************************************************************************
'************************** BEGINN CODE *******************************
$IID_IUNKNOWN = "{00000000-0000-0000-C000-000000000046}"
$IID_ICPC = "{B196B284-BAB4-101A-B69C-00AA00341D07}"
$IID_IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
#IF NOT %DEF(%CC_STDCALL)
%CC_STDCALL = 4
#ENDIF
TYPE W_VTABLE
fPtr AS DWORD PTR
END TYPE
TYPE W_ConnectInstanzInfo
pUnknown AS W_VTABLE PTR
pTypeInfo AS W_VTABLE PTR
ConPoint AS W_VTABLE PTR
Cookie AS DWORD
Prefix AS STRING * 32
IID AS GUID
END TYPE
TYPE IDLDESC DWORD
dwReserved AS DWORD
wIDLFlags AS WORD
END TYPE
UNION TYPEDESCDATA
lptdesc AS DWORD
lpadesc AS DWORD
hreftype AS DWORD
END UNION
TYPE TYPEDESC DWORD
tdd AS TYPEDESCDATA
vt AS WORD
END TYPE
TYPE TYPEATTR
rguid AS GUID
lcid AS DWORD
dwReserved AS DWORD
memidConstructor AS LONG
memidDestructor AS LONG
lpstrSchema AS DWORD
cbSizeInstance AS DWORD
typekind AS DWORD
cFuncs AS WORD
cVars AS WORD
cImplTypes AS WORD
cbSizeVft AS WORD
cbAlignment AS WORD
wTypeFlags AS WORD
wMajorVerNum AS WORD
wMinorVerNum AS WORD
tdescAlias AS TYPEDESC
idldescType AS IDLDESC
END TYPE
TYPE PARAMDESCEX
cBytes AS DWORD
filler AS DWORD
varDefaultValue AS VARIANTAPI
END TYPE
TYPE PARAMDESC DWORD
pparamdescex AS PARAMDESCEX PTR
wParamFlags AS WORD
END TYPE
TYPE ELEMDESC
tdesc AS TYPEDESC
prmdesc AS PARAMDESC
END TYPE
TYPE FUNCDESC
memid AS LONG
lprgscode AS LONG PTR
lprgelemdescParam AS ELEMDESC PTR
funckind AS DWORD
invkind AS DWORD
callconv AS DWORD
cParams AS INTEGER
cParamsOpt AS INTEGER
oVft AS INTEGER
cScodes AS INTEGER
elemdescFunc AS ELEMDESC
wFuncFlags AS WORD
END TYPE
'************* Prototypen
DECLARE FUNCTION PInvoke (BYVAL pInterface AS DWORD) AS LONG
DECLARE FUNCTION PInvoke1 (BYVAL pInterface AS DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke2 (BYVAL pInterface AS DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke3 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD) AS LONG
DECLARE FUNCTION PInvoke4 (BYVAL pInterface AS DWORD, DWORD, DWORD, DWORD, DWORD) AS LONG
'****************************************************************************************
DECLARE FUNCTION AtlAxWinInit LIB "ATL.dll" ALIAS "AtlAxWinInit" () AS LONG
DECLARE FUNCTION AtlAxGetControl LIB "ATL.dll" _
ALIAS "AtlAxGetControl" ( _
BYVAL hWnd AS DWORD, _
pUnk AS IUNKNOWN) AS LONG
DECLARE FUNCTION AtlAxGetHost LIB "ATL.dll" _
ALIAS "AtlAxGetHost" ( _
BYVAL hWnd AS DWORD, _
pUnk AS IUNKNOWN) AS LONG
DECLARE FUNCTION DispCallFunc LIB "oleaut32.dll" _
ALIAS "DispCallFunc" ( _
BYVAL pvInstance AS DWORD, _
BYVAL oVft AS DWORD, _
BYVAL cc AS LONG, _
BYVAL vtReturn AS WORD, _
BYVAL cActuals AS DWORD, _
BYREF prgvt AS WORD, _
BYREF prgvarg AS LONG, _
BYREF pvargResult AS LONG) AS LONG
GLOBAL W_Instances() AS W_ConnectInstanzInfo
GLOBAL W_IsAdvise AS BYTE
GLOBAL refCount AS DWORD
'************IDISPATCH Interface***********************
FUNCTION W_QueryInterface(pSource AS IUNKNOWN, IID AS GUID, pIUnknown AS IUNKNOWN) AS LONG
DIM i AS LONG
IF W_IsAdvise = 1 THEN
CopyMemory VARPTR(pIUnknown), VARPTR(W_Instances(UBOUND(W_Instances)).pUnknown), 4
W_Instances(UBOUND(W_Instances)).IID = IID
FUNCTION = %S_OK
INCR refCount
EXIT FUNCTION
ELSE
FOR i=0 TO UBOUND(W_Instances())
IF W_Instances(i).IID = IID THEN
CopyMemory VARPTR(pIUnknown), VARPTR(W_Instances(i).pUnknown), 4
FUNCTION = %S_OK
EXIT FUNCTION
END IF
NEXT
END IF
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_AddRef(pVtbl AS W_VTABLE PTR) AS LONG
INCR refCount
FUNCTION = refCount
END FUNCTION
FUNCTION W_Release(pVtbl AS W_VTABLE PTR) AS LONG
DIM i AS LONG
DIM pV AS W_VTABLE PTR
FOR i = 0 TO UBOUND(W_Instances())
IF W_Instances(i).pUnknown = pVtbl THEN
'UnAdvise
DECR refCount
pV=W_Instances(i).ConPoint
CALL DWORD @pV.@fPtr[6] USING PInvoke1(pV, BYVAL W_Instances(i).Cookie)
CALL DWORD @pV.@fPtr[2] USING PInvoke(pV)
CoTaskMemFree W_Instances(i).pUnknown
ARRAY DELETE W_Instances(i)
END IF
NEXT
FUNCTION = refCount
END FUNCTION
FUNCTION W_GetTypeInfoCount(pctinfo AS W_VTABLE PTR) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_GetTypeInfo(itinfo AS W_VTABLE PTR, BYVAL lcid AS LONG, pptinfo AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_GetIDsOfNames(itinfo AS W_VTABLE PTR, BYREF riid AS GUID, rgszNames AS ASCIIZ, _
BYVAL cNames AS DWORD, BYVAL lcid AS LONG, rgdispid AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
FUNCTION W_Invoke(BYREF Sender AS W_VTABLE PTR, BYVAL dispidMember AS LONG, BYREF riid AS GUID , BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, _
BYREF pdispparams AS DISPPARAMS, BYREF pvarResult AS VARIANT, BYREF pexcepinfo AS DWORD, BYREF puArgErr AS DWORD) AS LONG
DIM pV AS W_VTABLE PTR
DIM i AS LONG
DIM n AS LONG
DIM b AS BYTE
DIM tfunc AS FuncDesc PTR
DIM ttype AS TypeAttr PTR
DIM ncount AS LONG
DIM rVal AS DWORD
DIM nOffset AS DWORD
DIM nParam AS LONG
DIM nRet AS LONG
b=0
FOR i=0 TO UBOUND(W_Instances())
IF W_Instances(i).pUnknown = Sender THEN
b = 1
EXIT FOR
END IF
NEXT
IF b= 0 THEN EXIT FUNCTION
pV = W_Instances(i).pTypeInfo
CALL DWORD @pV.@fPtr[3] USING PInvoke1(pV, BYVAL VARPTR(ttype)) TO rVal
b = 0
FOR n = 0 TO @ttype.cFuncs-1
CALL DWORD @pV.@fPtr[5] USING PInvoke2(pV, BYVAL n, BYVAL VARPTR(tfunc)) TO rVal
IF @tfunc.memID = dispidMember THEN
nParam = @tfunc.cParams
b = 1
EXIT FOR
END IF
CALL DWORD @pV.@fPtr[20] USING PInvoke1(pV, BYVAL VARPTR(tfunc)) TO rVal
NEXT
nOffset = 28 + (n * 4)
rVal = DispCallFunc(Sender, nOffset, %cc_stdcall, %VT_I4, 0, 0&, 0&, BYVAL VARPTR(nRet))
FUNCTION = %E_NOTIMPL
END FUNCTION
'**********************************************************
FUNCTION W_GetConnectionPoint(vpUnk AS VARIANT) AS DWORD
DIM IID AS GUID
DIM Container AS W_VTABLE PTR
DIM EnumPoints AS W_VTABLE PTR
DIM ConnPoint AS W_VTABLE PTR
DIM rVal AS DWORD
DIM i AS DWORD
DIM pUnk AS IUNKNOWN
SET pUnk = vpUnk
'IConnectionPointContainer
IID = GUID$($IID_ICPC)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(Container))
IF rVal <> %S_OK THEN EXIT FUNCTION
'IEnumConnectionPoints
CALL DWORD @Container.@fPtr[3] USING PInvoke1(Container, BYVAL VARPTR(EnumPoints)) TO rVal
IF rVal <> %S_OK THEN
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
FUNCTION = 1
EXIT FUNCTION
END IF
'Zurücksetzen - reset
CALL DWORD @EnumPoints.@fPtr[5] USING PInvoke(EnumPoints) TO rVal
IF rVal <> %S_OK THEN
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
FUNCTION = 2
EXIT FUNCTION
END IF
'IConnectionPoint
CALL DWORD @EnumPoints.@fPtr[3] USING PInvoke3(EnumPoints, 1, BYVAL VARPTR(ConnPoint), i) TO rVal
IF rVal = 0 THEN
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
CALL DWORD @Container.@fPtr[2] USING PInvoke(Container) TO rVal
FUNCTION = 3
EXIT FUNCTION
END IF
'Release IEnumConnectionPoints
CALL DWORD @EnumPoints.@fPtr[2] USING PInvoke(EnumPoints) TO rVal
FUNCTION = ConnPoint
END FUNCTION
FUNCTION W_DISPDummy() AS LONG
END FUNCTION
FUNCTION W_EventDummy (sender AS IUNKNOWN) AS LONG
END FUNCTION
FUNCTION W_EventDummy1 (sender AS IUNKNOWN, A AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy2 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy3 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy4 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy5 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy6 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy7 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy8 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy9 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD, I AS DWORD) AS LONG
END FUNCTION
FUNCTION W_EventDummy10 (sender AS IUNKNOWN, A AS DWORD, B AS DWORD, C AS DWORD, D AS DWORD, E AS DWORD, _
F AS DWORD, G AS DWORD, H AS DWORD, I AS DWORD, J AS DWORD) AS LONG
END FUNCTION
FUNCTION W_GetBString(sfooName AS BYTE PTR) AS STRING
LOCAL s AS STRING,si AS STRING
LOCAL i AS LONG
FOR i= 0 TO 255 STEP 2
si = CHR$(@sfooName[i])
IF ASC(Si) > 40 THEN
s = s & si
ELSE
FUNCTION = TRIM$(s)
EXIT FUNCTION
END IF
NEXT
FUNCTION = TRIM$(s)
END FUNCTION
FUNCTION W_CreateEventSink(pConP AS W_VTABLE PTR, fooList() AS DWORD) AS LONG
DIM EventSink AS W_VTABLE PTR
DIM ttyp AS TYPEATTR PTR
DIM pV AS W_VTABLE PTR
DIM rVal AS DWORD
DIM wFlags AS DWORD
DIM i AS LONG
DIM dwCookie AS DWORD
'IDispatch-Interface Eventsink
EventSink = CoTaskMemAlloc(8)
@EventSink.fPtr = CoTaskMemAlloc(28)
@EventSink.@fPtr[0] = CODEPTR(W_QueryInterface)
@EventSink.@fPtr[1] = CODEPTR(W_AddRef)
@EventSink.@fPtr[2] = CODEPTR(W_Release)
@EventSink.@fPtr[3] = CODEPTR(W_GetTypeInfoCount)
@EventSink.@fPtr[4] = CODEPTR(W_GetTypeInfo)
@EventSink.@fPtr[5] = CODEPTR(W_GetIDsOfNames)
@EventSink.@fPtr[6] = CODEPTR(W_Invoke)
pV = W_Instances(UBOUND(W_Instances)).pTypeInfo
CALL DWORD @pV.@fPtr[3] USING PInvoke1(pV, BYVAL VARPTR(ttyp)) TO rVal
wFlags = @ttyp.wTypeFlags
CALL DWORD @pV.@fPtr[19] USING PInvoke1(pV, BYVAL VARPTR(ttyp)) TO rVal
IF wFlags > &H1000 THEN
'IDispatch-VTABLE
pv = CoTaskMemAlloc(8)
@pv.fPtr = CoTaskMemAlloc(28 + (UBOUND(fooList()) * 4))
@pv.@fPtr[0] = CODEPTR(W_QueryInterface)
@pv.@fPtr[1] = CODEPTR(W_AddRef)
@pv.@fPtr[2] = CODEPTR(W_Release)
@pv.@fPtr[3] = CODEPTR(W_GetTypeInfoCount)
@pv.@fPtr[4] = CODEPTR(W_GetTypeInfo)
@pv.@fPtr[5] = CODEPTR(W_GetIDsOfNames)
@pv.@fPtr[6] = CODEPTR(W_Invoke)
FOR i = 0 TO UBOUND(fooList())
SELECT CASE fooList(i)
CASE CODEPTR(W_EventDummy):fooList(i)=0
CASE CODEPTR(W_EventDummy1):fooList(i)=0
CASE CODEPTR(W_EventDummy2):fooList(i)=0
CASE CODEPTR(W_EventDummy3):fooList(i)=0
CASE CODEPTR(W_EventDummy4):fooList(i)=0
CASE CODEPTR(W_EventDummy5):fooList(i)=0
CASE CODEPTR(W_EventDummy6):fooList(i)=0
CASE CODEPTR(W_EventDummy7):fooList(i)=0
CASE CODEPTR(W_EventDummy8):fooList(i)=0
CASE CODEPTR(W_EventDummy9):fooList(i)=0
CASE CODEPTR(W_EventDummy10):fooList(i)=0
END SELECT
@pv.@fPtr[7+i] = fooList(i)
NEXT
ELSE
'IUnknown-VTABLE
pv = CoTaskMemAlloc(8)
@pv.fPtr = CoTaskMemAlloc(12 + (UBOUND(fooList()) * 4))
@pv.@fPtr[0] = CODEPTR(W_QueryInterface)
@pv.@fPtr[1] = CODEPTR(W_AddRef)
@pv.@fPtr[2] = CODEPTR(W_Release)
FOR i = 0 TO UBOUND(fooList())
@pv.@fPtr[3+i] = fooList(i)
NEXT
END IF
'Advise EventSink-Connectionpoint
W_Instances(UBOUND(W_Instances)).pUnknown = pV
W_IsAdvise = 1
CALL DWORD @pConP.@fPtr[5] USING pInvoke2(pConP, BYVAL EventSink, dwCookie) TO rVal
W_IsAdvise = 0
W_Instances(UBOUND(W_Instances)).Cookie = dwCookie
END FUNCTION
FUNCTION CreateControl(BYVAL sProgID AS STRING, BYVAL hWnd AS DWORD , _
BYVAL x AS LONG, BYVAL y AS LONG, BYVAL cx AS LONG, _
BYVAL cy AS LONG, myObj AS VARIANT) AS DWORD
DIM clsIDProg AS GUID
DIM hCtl AS DWORD
DIM b AS DWORD
DIM s AS ASCIIZ * 255
DIM pUnk AS IUNKNOWN
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
AtlAxWinInit
s = sProgID
IF hWnd = 0 THEN
hCtl = CreateWindowEx(0,"AtlAxWin", s, %WS_OVERLAPPEDWINDOW OR %WS_VISIBLE, x, y, cx, cy, 0, 0, _
GetModuleHandle(""), b)
IF hCtl THEN
AtlAxGetControl hCtl, BYVAL VARPTR(pUnk)
SET myObj = pUnk
FUNCTION = hCtl
END IF
ELSE
hCtl = CreateWindowEx(0,"AtlAxWin", s, %WS_CHILD OR %WS_VISIBLE, x, y, cx, cy, hWnd, 0, _
GetModuleHandle(""), b)
IF hCtl THEN
SetParent hCtl, hWnd
AtlAxGetControl hCtl, BYVAL VARPTR(pUnk)
SET myObj = pUnk
FUNCTION = hCtl
END IF
END IF
END FUNCTION
FUNCTION CreateDispEvents(BYVAL sProgID AS STRING, BYVAL sFuncPrefix AS STRING, myobj AS VARIANT) AS LONG
DIM clsIDProg AS GUID
DIM IID AS GUID
DIM IID_Connection AS GUID
DIM obj AS DISPATCH
DIM rVal AS DWORD
DIM pUnk AS IUNKNOWN
DIM pDisp AS IDISPATCH
DIM instcount AS LONG
DIM vUnk AS VARIANT
DIM Conpoint AS W_VTABLE PTR
DIM ITypeLib AS W_VTABLE PTR
DIM pV AS W_VTABLE PTR
DIM i AS DWORD
DIM b AS DWORD
DIM nAdr AS DWORD
DIM paramCount AS DWORD
DIM fooName AS BYTE PTR
DIM fooList() AS DWORD
clsIDProg = CLSID$(sProgID)
IF PROGID$(clsIDProg) = "" THEN EXIT FUNCTION
IF VARIANTVT(myobj) <> %VT_DISPATCH THEN
SET obj = NEW DISPATCH IN sProgID
IF OBJPTR(obj) = 0 THEN EXIT FUNCTION
SET vUnk = obj
ELSEIF VARIANTVT(myObj) = %VT_DISPATCH THEN
SET obj = myobj
SET vUnk = obj
ELSE
GOTO CleanUp1
END IF
ConPoint = W_GetConnectionPoint(vUnk)
IF ConPoint = 0 THEN GOTO CleanUp1
CALL DWORD @ConPoint.@fPtr[3] USING PInvoke1(ConPoint, BYVAL VARPTR(IID_Connection)) TO rVal
IF rVal <> %S_OK THEN GOTO CleanUp1
SET pUnk = obj
IID = GUID$($IID_IDispatch)
rVal = pUnk.QueryInterface(IID, BYVAL VARPTR(pDisp))
IF rVal <> %S_OK THEN GOTO CleanUp1
instcount = UBOUND(W_Instances()) + 1
REDIM PRESERVE W_Instances(instcount)
W_Instances(instcount).ConPoint = ConPoint
rVal = pDisp.GetTypeInfo(0, %NULL, BYVAL VARPTR(W_Instances(instcount).pTypeInfo))
IF rVal <> %S_OK THEN GOTO CleanUp2
pV = W_Instances(instcount).pTypeInfo
'GetTypeLib
CALL DWORD @pV.@fPtr[18] USING PInvoke2(pV, ITypeLib, i) TO rVal
CALL DWORD @pV.@fPtr[2] USING PInvoke(pV) 'Release pDisp::ITypeInfo
IF rVal <> %S_OK THEN GOTO CleanUp2
CALL DWORD @ITypeLib.@fPtr[6] USING PInvoke2(ITypeLib, BYVAL VARPTR(IID_Connection), _
BYVAL VARPTR(W_Instances(instcount).pTypeInfo)) TO rVal
CALL DWORD @ITypeLib.@fPtr[2] USING PInvoke(ITypeLib) 'Release ITypeLib
IF rVal <> %S_OK THEN CleanUp2
'Read the TypeInformations
pV = W_Instances(instcount).pTypeInfo
DIM ttyp AS TYPEATTR PTR
DIM tfunc AS FUNCDESC PTR
'Get TypeAttributes
CALL DWORD @pV.@fPtr[3] USING PInvoke1(pV, BYVAL VARPTR(ttyp)) TO rVal
IF rVal = %S_OK THEN
FOR i = 0 TO @ttyp.cFuncs - 1
CALL DWORD @pV.@fPtr[5] USING PInvoke2(pV, BYVAL i, BYVAL VARPTR(tfunc)) TO rVal
CALL DWORD @pV.@fPtr[7] USING PInvoke4(pV, BYVAL @tfunc.memID, fooname, BYVAL 1, b) TO rVal
REDIM PRESERVE fooList(i)
paramcount = @tfunc.cParams
IF b > 10 THEN
MSGBOX "W_EventDump" & STR$(b) & " requiered" , %MB_ICONSTOP, "COMEvent.Inc-Intern Message"
GOTO CleanUp2
END IF
nAdr = GetProcAddress(GetModuleHandle(""), sFuncPrefix & "_" & W_GetBString(fooname))
IF nAdr <> 0 THEN
fooList(i) = nAdr
ELSE
SELECT CASE paramcount
CASE 0 : fooList(i)=CODEPTR(W_EventDummy)
CASE 1 : fooList(i)=CODEPTR(W_EventDummy1)
CASE 2 : fooList(i)=CODEPTR(W_EventDummy2)
CASE 3 : fooList(i)=CODEPTR(W_EventDummy3)
CASE 4 : fooList(i)=CODEPTR(W_EventDummy4)
CASE 5 : fooList(i)=CODEPTR(W_EventDummy5)
CASE 6 : fooList(i)=CODEPTR(W_EventDummy6)
CASE 7 : fooList(i)=CODEPTR(W_EventDummy7)
CASE 8 : fooList(i)=CODEPTR(W_EventDummy8)
CASE 9 : fooList(i)=CODEPTR(W_EventDummy9)
CASE 10 : fooList(i)=CODEPTR(W_EventDummy10)
END SELECT
END IF
CALL DWORD @pV.@fPtr[20] USING PInvoke1(pV, BYVAL VARPTR(tfunc)) TO rVal
NEXT
CALL DWORD @pV.@fPtr[19] USING PInvoke1(pV, BYVAL VARPTR(ttyp)) TO rVal
W_CreateEventSink ConPoint, fooList()
END IF
IF VARIANTVT(myObj)<> %VT_DISPATCH THEN
SET myObj = obj
END IF
EXIT FUNCTION
CleanUp2:
ARRAY DELETE W_Instances(instcount)
CleanUp1:
SET obj = NOTHING
END FUNCTION
'***************************** EOF FILE *************************************
'****************************************************************************
#ENDIF
--------------------
Lordchen
(Der Mann der schneller proggt als sein Schatten)
Bearbeitet von Lordchen (22:44 27/03/2007)
|
|
0 registrierte und 2 anonyme Benutzer betrachten dieses Forum.
Moderator: MiB, VFensterB, Lordchen, Claus, Helmut
drucke Thema
|
Rechte
Du kannst keine neue Nachrichten schreiben
Du kannst keine Antworten schreiben
HTML ist deaktiviert
UBBCode ist aktiv
|
Bewertung:
Thema gelesen: 5176
|
|
|
|
|
|
UBB.threads™ 6.5.1
|
zurück
Index
vor
gestaffelt
ändern
antworten
Zitat
