PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

disphelper in PB: COM-Programmierung leicht gemacht

https://www.purebasic.fr/german/viewtopic.php?t=8126

Seite 1 von 4

disphelper in PB: COM-Programmierung leicht gemacht

Verfasst: 28.04.2006 00:05
von Kiffi
Hallo,

wer VBScript ein wenig kennt, der weiss vielleicht, dass die Verwendung
von COM-Objekten relativ einfach zu handhaben ist.

Code: Alles auswählen

myObject = CreateObject("Microsoft.XMLDOM")
myObject.Load("MeineXmlDatei.Xml")
Hier wird also ein COM-Objekt erzeugt und sofort kann damit gearbeitet
werden.

Unter PB gestaltet sich die Aufgabe ein wenig komplizierter. Wenn man auf
ein COM-Objekt zugreifen möchte, dann muss man zuvor ein
entsprechendes Interface schreiben, in dem festgelegt wird, welche
Methoden dieses Objektes mit welchen Parametern aufzurufen sind. Wer
mal einen Blick in meinen MSXML-Wrapper (im PBOSL-Paket) geworfen
hat, kann erahnen, dass das eine ziemlich umfangreiche und ermüdende
Arbeit ist (und das frustrierende ist: Mit meinem Wrapper kann man
nur das MSXML-Objekt verwenden; viele hundert andere COM-Objekte
warten nur darauf, dass man sie 'anzapft').

Wäre es also nicht viel besser, wenn man COM-Objekte in einer ähnlichen
Syntax ansprechen könnte, wie man es in dem VB-Script-Schnippsel oben
tut?

Der ein oder andere Interessierte hat sich vielleicht mal FreeBasic
angeschaut. Dort gibt's ein Include namens disphelper.bi. Wenn man diese
Datei in sein Projekt einbindet, dann ist man dort in der Lage, folgende
Syntax zu verwenden:

Code: Alles auswählen

dhCreateObject( "Microsoft.XMLDOM", NULL, @myObject )
dhCallMethod( myObject, ".Load(%s)", "MeineXmlDatei.Xml" )
Also man kann COM-Objekte erzeugen (dhCreateObject), Methoden
aufrufen (dhCallMethod), Werte setzen (dhGetValue) und auslesen
(dhGetValue). Das geht wunderbar einfach.

Die FreeBasic-disphelper.bi-Datei ist eine Umsetzung eines C-Codes, der
hier zu finden ist (besteht aus einer *.c- und einer *.h-Datei). Leider bin
ich sowohl fachlich und auch vom zeitlichen nicht in der Lage, diesen Code
unter PB nutzbar zu machen. Zwar kann man die Routine prima in eine
DLL kompilieren, die man mit PB öffnen kann, die Parameterübergabe
jedoch macht mir Kopfzerbrechen. Auch an einem Import eine statischen
Lib bin ich bisher gescheitert.

Obwohl ich persönlich an dieser Stelle das disphelper-Handtuch werfen
werde, wäre es dennoch schade, wenn man eine so schöne Erleichterung
für die Programmierung von COM-Objekten unter PB so einfach unter den
Tisch fallen lassen würde.

Vielleicht erbarmt sich ja jemand, aus dem C-Code eine Dll oder Lib für PB
zu erzeugen und diese einbindbar zu machen. Nicht übel wäre jedoch eine
komplette Konvertierung des C-Codes in PB :allright:

Damit würde man der PB-Community die Tür zur grossen weiten Welt der
COM-Programmierung aufstossen. :-)

Grüße ... Kiffi

Verfasst: 28.04.2006 00:42
von edel

Code: Alles auswählen

[...]
declare function dhPutRef cdecl alias "dhPutRef" (byval pDisp as IDispatch ptr, byval szMember as LPCOLESTR, ...) as HRESULT
[...]
bzw

Code: Alles auswählen

[...]
dhCallMethod(IDispatch * pDisp, LPCOLESTR szMember, ...);
[...]
Denke nicht das man sowas in PB umsetze koennte , oder ?

Verfasst: 28.04.2006 00:48
von ts-soft
hallodri hat geschrieben:

Code: Alles auswählen

[...]
declare function dhPutRef cdecl alias "dhPutRef" (byval pDisp as IDispatch ptr, byval szMember as LPCOLESTR, ...) as HRESULT
[...]
Denke nicht das man sowas in PB umsetze koennte , oder ?

Code: Alles auswählen

; [...]
; Declare function dhPutRef cdecl alias "dhPutRef" (byval pDisp As IDispatch ptr, byval szMember As LPCOLESTR, ...) As HRESULT
; [...] 

ProcedureC.l dhPutRef(*pdisp.IDispatch, szMember.p-bstr)
EndProcedure
:wink:
soweit ganz einfach

Verfasst: 28.04.2006 00:54
von mk-soft
@Kiffi,

Interessanter Link. Habe ich mir mal geladen. Mein aktulles Projekt ist gerade eigende DCOM-Objekte zu schreiben und arbeite mich gerade in die strukturen und funktionen ein um diese zu reallisieren. Ist noch ein weiter weg bis auch die iDispatch voll unterstützt wird. Und man muss auch noch nebenbei arbeiten. Werde ich mir bei gelegenheit mal anschauen.

FF :wink:

Verfasst: 28.04.2006 01:26
von mk-soft
Eine eins-zu-eins übersetzung wäre nicht erforderlich da c/cpp etwas anders struktuiert ist. Einfacher geht es zum beispiel über ATL.DLL ein Container zu erzeugen und über die IDisptach die Funktionsnamen und deren ID auszulesen (GetIDsOfNames). Danach über Invoke die Funktion aufrufen. Etwas anders macht VC5 auch nicht. VC5 baut sich nach einbinden des COM/DCOM-Object selber ein Wrapper. Lässt sich sehr gut nach PB über setzen.

Klingt zwar recht einfach, ist aber trotzdem noch viel arbeit bis alles läuft.

FF :wink:

Verfasst: 28.04.2006 09:21
von Kiffi
Hallo Leute,

erstmal vielen Dank für Euer Feedback! :allright:
mk-soft hat geschrieben:Lässt sich sehr gut nach PB über setzen.
das hört sich doch schon mal sehr gut an. :D Bin gespannt!

Grüße ... Kiffi

Verfasst: 28.04.2006 20:13
von remi_meier
ts-soft hat geschrieben:

Code: Alles auswählen

; [...]
; Declare function dhPutRef cdecl alias "dhPutRef" (byval pDisp As IDispatch ptr, byval szMember As LPCOLESTR, ...) As HRESULT
; [...] 

ProcedureC.l dhPutRef(*pdisp.IDispatch, szMember.p-bstr)
EndProcedure
:wink:
soweit ganz einfach
hast du den Code mal kompiliert? Pseudotypen gehen nämlich nur bei
Funktionsdeklarationen, nicht bei Funktionsdefinitionen <)

Geht also nur als C-Library (Userlibrary)

Verfasst: 29.04.2006 16:17
von schic
bin seit einiger Zeit dran so etwas umzusetzen.

Das Grundgerüst steht schon. Man kann damit ohne
Interfaces zu importieren oder CLSIDs zu kennen
auf Excel Word und Co. zugreifen
Hier ein Beispiel mit Excel in PB 3.94

Code: Alles auswählen

; http://support.microsoft.com/kb/216686/EN-US/
; How To Automate Excel From C++ Without Using MFC or #import
; transfered and extend from VC++ to PureBasic from schic

Enumeration   ; VARENUM
  #VT_EMPTY = 0
  #VT_NULL = 1
  #VT_I2 = 2
  #VT_I4 = 3
  #VT_R4 = 4
  #VT_R8 = 5
  #VT_CY = 6
  #VT_DATE = 7
  #VT_BSTR = 8
  #VT_DISPATCH = 9
  #VT_ERROR = 10
  #VT_BOOL = 11
  #VT_VARIANT = 12
  #VT_UNKNOWN = 13
  #VT_DECIMAL = 14
  #VT_I1 = 16
  #VT_UI1 = 17
  #VT_UI2 = 18
  #VT_UI4 = 19
  #VT_I8 = 20
  #VT_UI8 = 21
  #VT_INT = 22
  #VT_UINT = 23
  #VT_VOID = 24
  #VT_HRESULT = 25
  #VT_PTR = 26
  #VT_SAFEARRAY = 27
  #VT_CARRAY = 28
  #VT_USERDEFINED = 29
  #VT_LPSTR = 30
  #VT_LPWSTR = 31
  #VT_RECORD = 36
  #VT_INT_PTR = 37
  #VT_UINT_PTR = 38
  #VT_FILETIME = 64
  #VT_BLOB = 65
  #VT_STREAM = 66
  #VT_STORAGE = 67
  #VT_STREAMED_OBJECT = 68
  #VT_STORED_OBJECT = 69
  #VT_BLOB_OBJECT = 70
  #VT_CF = 71
  #VT_CLSID = 72
  #VT_VERSIONED_STREAM = 73
  #VT_BSTR_BLOB = $FFF
  #VT_VECTOR = $1000
  #VT_ARRAY = $2000
  #VT_BYREF = $4000
  #VT_RESERVED = $8000
  #VT_ILLEGAL = $FFFF
  #VT_ILLEGALMASKED = $FFF
  #VT_TYPEMASK = $FFF
EndEnumeration 

;{-Constants
#CLSCTX_INPROC_SERVER  = $1
#CLSCTX_INPROC_HANDLER = $2
#CLSCTX_LOCAL_SERVER   = $4
#CLSCTX_REMOTE_SERVER  = $10
#CLSCTX_ALL = (#CLSCTX_INPROC_SERVER|#CLSCTX_INPROC_HANDLER|#CLSCTX_LOCAL_SERVER|#CLSCTX_REMOTE_SERVER)

#DISPID_PROPERTYPUT = -3

#DISPATCH_METHOD          = 1
#DISPATCH_PROPERTYGET     = 2
#DISPATCH_PROPERTYPUT     = 4
#DISPATCH_PROPERTYPUTREF  = 8
;}

Structure xBRECORD
  *pvRecord.l
  *pRecInfo.IRecordInfo
EndStructure

Structure xVARIANT
  vt.w
  wReserved1.w
  wReserved2.w
  wReserved3.w
  StructureUnion
    llVal.LARGE_INTEGER
    lVal.l
    bVal.b
    iVal.b
    fltVal.f
    dblVal.LARGE_INTEGER
    boolVal.l
    bool.l
    scode.l
    cyVal.l
    date.l
    bstrVal.l
    *punkVal.IUnknown
    ;punkVal.l
    *pdispVal.IDispatch
    parray.l
    pbVal.b
    piVal.b
    plVal.l
    pllVal.LARGE_INTEGER
    pfltVal.f
    pdblVal.LARGE_INTEGER
    pboolVal.l
    pbool.l
    pscode.l
    pcyVal.l
    pdate.l
    pbstrVal.b
    ppunkVal.l;.IUnknown
    ppdispVal.IDispatch
    pparray.l
    pvarVal.l;.xVARIANT
    *byref
    cVal.b
    uiVal.b
    ulVal.l
    ullVal.LARGE_INTEGER
    intVal.l
    uintVal.l
    *pdecVal.f
    *pcVal.b
    *puiVal.b
    *pulVal.l
    *pullVal.LARGE_INTEGER
    *pintVal.l
    *puintVal.l
    *record.xBRECORD
  EndStructureUnion
EndStructure 

Structure DISPPARAMS
  *rgvarg.l               ;array of arguments xVARIANT
  ;*rgvarg.Variant[0]
  *rgdispidNamedArgs.l  ;array of Dispatch IDs of named arguments (argument 0 index)
  ; rgdispidNamedArgs.l
  cArgs.l               ;Number of arguments
  cNamedArgs.l          ;Number of named arguments
EndStructure

Structure EXCEPINFO 
    wCode.w;
    wReserved.w;
    bstrSource.s;
    bstrDescription.s;
    bstrHelpFile.s;
    dwHelpContext.l;
    pvReserved.l ;
    pfnDeferredFillIn.l
    scode.l ;
EndStructure

Structure SAFEARRAYBOUND
  cElements.l ;ULONG
  lLbound.l ;LONG
EndStructure

;{-Globals
Global pApp.IDispatch
Global pvResult.xVARIANT
Global IID_NULL.GUID
;}

Dim varArr.xVARIANT(0)

Procedure AutoWrap(autoTyp.l, *pDisp.IDispatch, name.s, nArgs.l)
  dispID.l
  exception.EXCEPINFO
  
  dp.DISPPARAMS
  dispidNamed = #DISPID_PROPERTYPUT
  
  ;Convert to Uni
  ptUniName = Ansi2Uni(name)
  Debug "getting IDs of names"
  ;Get DISPID for name passed...
  hr = *pDisp\GetIDsOfNames(IID_NULL, @ptUniName, 1, #LOCALE_USER_DEFAULT, @dispID) 
  Debug "hr GetIDsOfNames: " + Str(hr)
  Debug "dispID from " + name + " = " + Str(dispID)
  
  ;Build DISPPARAMS
  dp\cArgs  = nArgs
  dp\rgvarg = @varArr(0) ;ArgsArr;pArgs;*var;
  
  ;Handle special-case for property-puts!
  If autoTyp & #DISPATCH_PROPERTYPUT
    dp\cNamedArgs = 1
    dp\rgdispidNamedArgs = @dispidNamed
  EndIf
  
  ;Make the call!
  hr = *pDisp\Invoke(dispID, IID_NULL, #LOCALE_SYSTEM_DEFAULT, autoTyp, @dp, @pvResult, @exception, #Null)
  Debug "hr Invoke: " + Str(hr)
  Debug "##########"
  Select hr
    Case #DISP_E_EXCEPTION
      Debug "exception\scode: " + Str(exception\scode) + " -> " + exception\bstrDescription
  EndSelect
  ; Invoke return values: 
  ; #S_OK	                      = 0            ; Success.
  ; #DISP_E_BADPARAMCOUNT	      = -21473525 62 ; The number of elements provided to DISPPARAMS is different from the number of arguments accepted by the method or property.
  ; #DISP_E_BADVARTYPE	        = -21473525 68 ; One of the arguments in rgvarg is not a valid variant type.
  ; #DISP_E_EXCEPTION	          = -21473525 67 ; The application needs to raise an exception. In this case, the structure passed in pExcepInfo should be filled in.
  ; #DISP_E_MEMBERNOTFOUND	    = -21473525 73 ; The requested member does not exist, or the call to Invoke tried to set the value of a read-only property.
  ; #DISP_E_NONAMEDARGS	        = -21473525 69 ; This implementation of IDispatch does not support named arguments.
  ; #DISP_E_OVERFLOW	          = -21473525 66 ; One of the arguments in rgvarg could not be coerced to the specified type.
  ; #DISP_E_PARAMNOTFOUND	      = -21473525 72 ; One of the parameter DISPIDs does not correspond to a parameter on the method. In this case, puArgErr should be set to the first argument that contains the error.
  ; #DISP_E_TYPEMISMATCH	      = -21473525 71 ; One or more of the arguments could not be coerced. The index within rgvarg of the first parameter with the incorrect type is returned in the puArgErr parameter.
  ; #DISP_E_UNKNOWNINTERFACE	  = -21473525 75 ; The interface identifier passed in riid is not IID_NULL.
  ; #DISP_E_UNKNOWNLCID	        = -21473525 64 ; The member being invoked interprets string arguments according to the LCID, and the LCID is not recognized. If the LCID is not needed to interpret arguments, this error should not be returned.
  ; #DISP_E_PARAMNOTOPTIONAL	  = -21473525 61 ; A required parameter was omitted.
  ;                               -2147024809  ; The parameter is incorrect (80070057)
  FreeMemory(ArgsArr)
  ProcedureReturn hr
EndProcedure


;{ get application object
CLSID.GUID 
hr = CLSIDFromProgID_(Ansi2Uni("Excel.Application"), @CLSID)
Debug hr
Debug CLSID\data1 ;148736 for Excel

pCf.IClassFactory = NULL

IID_IClassFactory.GUID
IID_IClassFactory\data1 = $1
IID_IClassFactory\data4[0] = $C0
IID_IClassFactory\data4[7] = $46

hr = CoGetClassObject_(@CLSID, #CLSCTX_LOCAL_SERVER, #Null, @IID_IClassFactory, @pCf)
Debug "hr CoGetClassObject: " + Hex(hr)

riid.GUID
riid\data1 = $20400
riid\data4[0] = $C0
riid\data4[7] = $46

pApp.IDispatch
ppApp=@pApp
hr = pCf\CreateInstance(#Null, @riid, @pApp)
Debug "hr CreateInstance: " + Hex(hr)
pCf\Release()
;}

;{ make application visible
Dim varArr.xVARIANT(1)
varArr(0)\vt = #VT_I4
varArr(0)\lVal = 1
AutoWrap(#DISPATCH_PROPERTYPUT, pApp, "Visible", 1)
VariantClear_(varArr(0))
;}

;{ get workbooks object, VBA-Code: Set pXlBooks = Application.Workbooks
pXlBooks.IDispatch
VariantInit_(@pvResult);
AutoWrap(#DISPATCH_PROPERTYGET, pApp, "Workbooks", 0)
Debug "Variant Typ: " + Str(pvResult\vt)
Debug "Workbooks, pvresult\pdispVal: " + Str(pvResult\pdispVal)
Debug "##"
pXlBooks = pvResult\pdispVal
;}

;{ add a workbook, VBA-Code: pXlBooks.Add
pXlBook.IDispatch
pvResult.xVARIANT
VariantInit_(@pvResult);
AutoWrap(#DISPATCH_PROPERTYGET, pXlBooks, "Add", 0)
pXlBook = pvResult\pdispVal
;}

;{ Get ActiveSheet object, VBA-Code: Set pXlSheet = Application.ActiveSheet
pXlSheet.IDispatch
VariantInit_(@pvResult);
AutoWrap(#DISPATCH_PROPERTYGET, pApp, "ActiveSheet", 0);
pXlSheet = pvResult\pdispVal
;}

;{ fill 15 x15 Range with Values at a single blow, VBA-Code: don´t know how to do it with VBA
;Get Range object for the Range A1:O15...
pXlRange.IDispatch
varArr(0)\vt = #VT_BSTR
varArr(0)\bstrVal = Ansi2Uni("A1:O15")
pvResult.xVARIANT
VariantInit_(@pvResult)
AutoWrap(#DISPATCH_PROPERTYGET, pXlSheet, "Range", 1)
VariantClear_(@varArr(0))
pXlRange = pvResult\pdispVal

;Create a 15x15 safearray of variants...
varArr(0)\vt = #VT_ARRAY | #VT_VARIANT
Dim sab.SAFEARRAYBOUND(1)
sab(0)\lLbound = 1
sab(0)\cElements = 15
sab(1)\lLbound = 1
sab(1)\cElements = 15
varArr(0)\parray = SafeArrayCreate_(#VT_VARIANT, 2, @sab(0))
Debug "arr\parray: " + Str(varArr(0)\parray)

;Fill safearray with some values...
Dim indices.l(1)
tmp.xVARIANT
For i = 1 To 15
  For j = 1 To 15
    ;Create entry value for (i,j)
    tmp\vt = #VT_I4
    tmp\lVal = i*j
    ;Add to safearray...
    indices(0) = i
    indices(1) = j
    hr = SafeArrayPutElement_(varArr(0)\parray, @indices(0), @tmp)
    ;Debug "hr from SafeArrayPutElement: " + Str(hr)
    ; -2147024809 = #E_INVALIDARG     ;An argument is invalid.
    ; -2147352565 = #DISP_E_BADINDEX  ;The specified index was invalid.
    ; -2147024882 = #E_OUTOFMEMORY    ;Memory could not be allocated for the element.
    VariantClear_(@tmp)
  Next
Next

;Set range with our safearray...
AutoWrap(#DISPATCH_PROPERTYPUT, pXlRange, "Value", 1)
;}

;{ put text to single cell in row 4, column 15, VBA-Code: Set pXlCells4_15 = Cells(4, 15): pXlCells4_15.Value = "COM-Test with Excel"
;arguments for column and row, cells(row,column)
;take care! arguments are handeled reverse
Dim varArr.xVARIANT(2)
varArr(0)\vt = #VT_I4
varArr(0)\lVal = 15

varArr(1)\vt = #VT_I4
varArr(1)\lVal = 4
;get cell-object
pXlCells4_15.IDispatch
pvResult.xVARIANT
VariantInit_(@pvResult)
If AutoWrap(#DISPATCH_PROPERTYGET, pXlSheet, "Cells", 2) = 0
  pXlCells4_15 = pvResult\pdispVal
EndIf
;set value
Dim varArr.xVARIANT(1)
varArr(0)\vt = #VT_BSTR
varArr(0)\bstrVal = Ansi2Uni("COM-Test with Excel")
AutoWrap(#DISPATCH_PROPERTYPUT,  pXlCells4_15, "Value", 1)
;}

;{ fit the width of all cells to their content, VBA-Code: Cells.EntireColumn.AutoFit
;get cells object
pXlCells.IDispatch
VariantInit_(@pvResult)
AutoWrap(#DISPATCH_PROPERTYGET, pXlSheet, "Cells", 0)
pXlCells = pvResult\pdispVal
;get EntireColumn-object
pXlEntireColumn.IDispatch
VariantInit_(@pvResult)
AutoWrap(#DISPATCH_PROPERTYGET, pXlCells, "EntireColumn", 0)
pXlEntireColumn = pvResult\pdispVal
;fit them, Cells.EntireColumn.AutoFit
AutoWrap(#DISPATCH_METHOD, pXlEntireColumn, "AutoFit", 0)
If pXlCells
  pXlCells\Release()
EndIf
;}

;{ set background color to single cell, row 4, column 15, VBA-Code: pXlCells4_15.Interior.ColorIndex = 36
pXlInterior.IDispatch
VariantInit_(@pvResult)
AutoWrap(#DISPATCH_PROPERTYGET, pXlCells4_15, "Interior", 0)
pXlInterior = pvResult\pdispVal

Dim varArr.xVARIANT(1)
varArr(0)\vt = #VT_I4
varArr(0)\lVal = 36
AutoWrap(#DISPATCH_PROPERTYPUT, pXlInterior, "ColorIndex", 1)
;}

; pXlCells4_15.Select
AutoWrap(#DISPATCH_METHOD, pXlCells4_15, "Select", 0)

If pXlCells4_15
  pXlCells\Release()
EndIf

varArr(0)\vt = #VT_I4
varArr(0)\lVal = 1
AutoWrap(#DISPATCH_PROPERTYPUT, pXlBook, "Saved", 1)

; AutoWrap(#DISPATCH_METHOD, pApp, "Quit", 0, 0)
; MessageRequester("Info", "Excel switched off")

;{ cleaning up
pXlInterior\Release()
pXlEntireColumn\Release()
pXlRange\Release()
pXlSheet\Release()
pXlBook\Release()
pXlBooks\Release()
pApp\Release()

CoUninitialize_()
;}

End
ist nicht so komfortabel wie das von http://disphelper.sourceforge.net/
aber dafür deutlich schneller.
Es wäre zu überlegen die Objekte in einer LinkedList mit String-Namen
und Zeiger zu sammeln. Wenn man eins weitere Male benötigt,
kann das dann aus der Liste gesucht werden.
Wie man PB-Typen (long, Word, String etc.) automatisiert und komfortabel
in Variants umwandelt, oder umgekehrt, dazu habe ich noch keine Idee.
Müsste sich aber auch realisieren lassen.

_____
schic

Verfasst: 29.04.2006 21:46
von mk-soft
@schic,
sieht sehr gut aus. werde ich noch testen :allright:

Verfasst: 30.04.2006 11:58
von Kiffi
schic hat geschrieben:bin seit einiger Zeit dran so etwas umzusetzen.
super, dass Du Dich hier mit einbringst! :allright:

Leider bekomme ich den Code nicht an's Laufen. Mein Debugger schmeisst
in dieser Zeile:

Code: Alles auswählen

hr = pCf\CreateInstance(#Null, @riid, @pApp)
einen 'invalid Memory-Access'. :(

Die Debug-Ausgaben sehen bis hierhin eigentlich ganz gut aus:
0
148736
hr CoGetClassObject: 800401F0
Was läuft da bei mir falsch?

Grüße ... Kiffi

//Edit:

Ah, ich habe das 2. hResult übersehen, welches nicht #S_OK ist.
Das ist bei mir übersetzt folgendes:
hr CoGetClassObject: CO_E_NOTINITIALIZED
Alle Zeiten sind UTC+02:00
Seite 1 von 4

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de