disphelper in PB: COM-Programmierung leicht gemacht

Beitrag von **Kiffi** » 01.05.2006 19:55

schic hat geschrieben:Bei mir liefert das:[...]

bei mir jetzt auch! Vielen Dank für Deine Hilfe!

Auch ein grosses Dankeschön an mk-soft für die Mühen!

Ihr seid klasse, Jungs!

Um auch noch eine Kleinigkeit konstruktives zu diesem Thread beizufügen:

Hier eine nützliche Funktion, die ich im englischen Forum gefunden habe und
die zu manchen hResult-Fehlern einen Text ausgibt:

Code: Alles auswählen

Procedure.s GetHResultMessage(HResult.l)
  ;Converts a COM HResult value into a more meaningful message.
  ;Params:
  ;     HResult.l A HResult value return from a COM call
 
  Message.s = ""
  Select HResult
    Case #S_OK
      Message = "OK"
    Case #CLASS_E_CLASSNOTAVAILABLE
      Message = "Class Not Available"
    Case #E_NOINTERFACE
      Message = "No Interface"
    Case #CO_E_NOTINITIALIZED
      Message = "CO_E_NOTINITIALIZED"
    Case #CO_E_ALREADYINITIALIZED
      Message = "CO_E_ALREADYINITIALIZED"
    Case #CO_E_CANTDETERMINECLASS
      Message = "CO_E_CANTDETERMINECLASS"
    Case #CO_E_CLASSSTRING
      Message = "The registered CLSID for the ProgID is invalid"
    Case #CO_E_IIDSTRING
      Message = "CO_E_IIDSTRING"
    Case #CO_E_APPNOTFOUND
      Message = "CO_E_APPNOTFOUND"
    Case #CO_E_APPSINGLEUSE
      Message = "CO_E_APPSINGLEUSE"
    Case #CO_E_ERRORINAPP
      Message = "CO_E_ERRORINAPP"
    Case #CO_E_DLLNOTFOUND
      Message = "CO_E_DLLNOTFOUND"
    Case #CO_E_ERRORINDLL
      Message = "CO_E_ERRORINDLL"
    Case #CO_E_WRONGOSFORAPP
      Message = "CO_E_WRONGOSFORAPP"
    Case #CO_E_OBJNOTREG
      Message = "CO_E_OBJNOTREG"
    Case #CO_E_OBJISREG
      Message = "CO_E_OBJISREG"
    Case #CO_E_OBJNOTCONNECTED
      Message = "CO_E_OBJNOTCONNECTED"
    Case #CO_E_APPDIDNTREG
      Message = "CO_E_APPDIDNTREG"
    Case #CO_E_RELEASED
      Message = "CO_E_RELEASED"
    Case #REGDB_E_WRITEREGDB
      Message = "An error occurred writing the CLSID To the registry."
    Case #E_OUTOFMEMORY
      Message = "Out of memory."
    Case #STG_E_INSUFFICIENTMEMORY
      Message = "Out of memory."
    Case #E_INVALIDARG
      Message = "One or more of the arguments is invalid."
    Case #DISP_E_UNKNOWNNAME
      Message = "One Or more of the names could not be found."
    Case #DISP_E_UNKNOWNLCID
      Message = "The locale identifier (LCID) could not be found in the OLE DLLs."
    Default
      Message = "Error Number: $" + Hex(HResult)
  EndSelect
 
  ProcedureReturn Message
EndProcedure

Grüße ... Kiffi

mk-soft · Beitrag von **mk-soft** » 01.05.2006 20:31

@Schic,
habe mir erlaubt dein Code anzupassen.

ComHelper.pb

Code: Alles auswählen

;-TOP
; Kommentar     : DCOM Object Helper
; Author        : mk-soft
; Second Author : 
; Datei         : ComHelper.pb
; Version       : 1.01
; Erstellt      : 01.05.2006
; Geändert      : 01.05.2006

; -------------------------------------------------------------------

;- Konstanten
#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)

; -------------------------------------------------------------------

;- Strukturen

; -------------------------------------------------------------------

; Globale Variablen
Global LastError.l
Global LastMessage.s

; -------------------------------------------------------------------

Procedure CreateObject(Object.s, CLSTYPE.l = #CLSCTX_LOCAL_SERVER | #CLSCTX_INPROC_SERVER)

  LastError = 0
  LastMessage = ""
  
  hr = CoInitialize_(0)
  If  hr <> #S_OK And hr <> #S_FALSE
    LastError = hr
    LastMessage = "Error CoInitialize: ErrorCode " + Hex(hr)
    End
  EndIf
  
  hr = CLSIDFromProgID_(Object, CLSID.GUID)
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CLSIDFromProgID: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  
  hr = CoGetClassObject_(@CLSID, CLSTYPE, #Null, ?IID_IClassFactory, @pCf.IClassFactory)
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CoGetClassObject: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  

  hr = pCf\CreateInstance(#Null, ?IID_IDispatch, @*Object.IDispatch)
  pCf\Release()
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CreateInstance: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  Else
    ProcedureReturn *Object
  EndIf
  
EndProcedure

; -------------------------------------------------------------------

Procedure ReleaseObject(*Object.IDispatch)

  If *Object
    *Object\Release()
  EndIf
  
EndProcedure

; ---------------------------------------------------------

;- DataSection IID

DataSection
  
  IID_NULL: ; {00000000-0000-0000-0000-000000000000}
  Data.l $00000000
  Data.w $0000, $0000
  Data.b $00, $00, $00, $00, $00, $00, $00, $00 
  
  IID_IUnknown : ; {00000000-0000-0000-C000-000000000046}'
  Data.l $00000000
  Data.w $0000, $0000, $C000
  Data.b $00 , $00 , $00, $00 , $00 , $46
  
  IID_IDispatch:
  Data.l $00020400
  Data.w $0000, $0000
  Data.b $C0,$00,$00,$00,$00,$00,$00,$46

  IID_IClassFactory:
  Data.l $00000001
  Data.w $0, $0
  Data.b $C0, $0, $0, $0, $0, $0, $0, $46
  
EndDataSection

Edit: #CLSCTX_LOCAL_SERVER | #CLSCTX_INPROC_SERVER ist jetzt Default

InvokeHelper.pb

Code: Alles auswählen

;-TOP
; Kommentar     : DCOM Invoke Helper
; Author        : Schic
; Second Author : mk-soft
; Datei         : InvokeHelper.pb
; Version       : 1.02
; Erstellt      : 01.05.2006
; Geändert      : 02.05.2006

; -------------------------------------------------------------------

;- Konstanten
#DISPID_PROPERTYPUT = -3

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

; -------------------------------------------------------------------

;- Strukturen
Structure xBRECORD  ; with PB 4 not necessary only for information
  *pvRecord.l
  *pRecInfo.IRecordInfo
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

; -------------------------------------------------------------------

;- Globale Variablen
Global pvResult.VARIANT
Global Dim varArr.VARIANT(0)
Global LastError.l
Global LastMessage.s

; -------------------------------------------------------------------

Procedure AutoWrap(autoTyp.l, *pDisp.IDispatch, Name.s, nArgs.l)

  dispID.l
  exception.EXCEPINFO
 
  dp.DISPPARAMS
  dispidNamed = #DISPID_PROPERTYPUT
 
  ;Get DISPID for name passed...
  ptUniName = @name
  hr = *pDisp\GetIDsOfNames(?IID_NULL, @ptUniName, 1, #LOCALE_USER_DEFAULT, @dispID)
  If hr <> #S_OK And hr <> #S_FALSE
    LastError = hr
    LastMessage = "Error GetIDsOfNames '" + Name + ": Errorcode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  ;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)
  If hr <> #S_OK And hr <> #S_FALSE
    LastError = hr
    LastMessage = "Error Invoke: Errorcode " + Hex(hr)
    Select hr
      Case #DISP_E_EXCEPTION
        LastMessage + " / Exception\Scode: " + Str(exception\scode) + " -> " + exception\bstrDescription
    EndSelect
    ProcedureReturn 0
  EndIf
  
  ; 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)
  
  ProcedureReturn 1
  
EndProcedure

Edit: AutoWrap(...) gibt eine 1 zurück wenn alles Ok ist

FF

mk-soft · Beitrag von **mk-soft** » 02.05.2006 01:40

@kiffi,
das beispiel von schic nun auch in Unicode

Code: Alles auswählen

; UNICODE

IncludeFile "ComHelper.pb"
IncludeFile "InvokeHelper.pb"

; VBS: Set myXML = CreateObject("Microsoft.XMLDOM")
; PB:
myXML = CreateObject("Microsoft.XMLDOM")
If myXML = 0
  Debug LastMessage
  End
EndIf

; VBS: strXML="<hallo>123</hallo>"
;PB:
Value.s = "<hallo>123</hallo>"
Dim varArr.Variant(1)
varArr(0)\vt = #VT_BSTR
varArr(0)\bstrVal = SysAllocStringLen_(Value, Len(Value))
; VBS: myXML.LoadXml strXML
; PB
AutoWrap(#DISPATCH_METHOD, myXML, "LoadXml", 1)

; VBS: pvResult = myXML.XML
; PB:
VariantInit_(pvResult)
AutoWrap(#DISPATCH_PROPERTYGET,  myXML, "XML", 0)
; ...
Debug pvResult\vt
Debug "XML = " + PeekS(pvResult\bstrVal)

Variant bstrVal ist als Long declariert was aber eigendlich ein Pointer auf ein String von Type Unicode ist. Der Pointer sollte besser mit SysAllocStringLen_(...) gesetzt werden, damit VariantClear_(...) auch den Speicher Ordnungsgemäss freigeben kann. Auslesen kann man immer mit PeekS(...).

FF

P.S. Denke ich werde #CLSCTX_LOCAL_SERVER | #CLSCTX_INPROC_SERVER als Default für CreateObject(...) setzen.
Edit: Erledigt

Beitrag von **freak** » 02.05.2006 02:06

Kiffi hat geschrieben:Hier eine nützliche Funktion, die ich im englischen Forum gefunden habe und
die zu manchen hResult-Fehlern einen Text ausgibt:

Das hier ist eine etwas komplettere Liste:
http://freak.purearea.net/stuff/ComErrors.pb

Ist der Inhalt von WinError.h per skript zum PB Source konvertiert.
Würde ich aber wegen der größe nur zu debugging Zwecken verwenden.

schic · Beitrag von **schic** » 02.05.2006 19:48

@mk-soft
Danke für das zusammenpacken und ordentliche Fehlerabfragen einbauen etc..
Wird schon almählich Zeit, das Ganze aus dem Experimentier/Debug Stadium
rauszubringen - ich weiß

Zu dem Unicode-Modus: Ich verstehe nicht wieso

Code: Alles auswählen

      strVar = Str(lZahl) + "Text"
      tmp\vt = #VT_BSTR
      tmp\bstrVal = @strVar

nicht funktioniert. Und das stört mich etwas. Und nicht zu vergessen
das Unicode-Zeug läuft unter Win9x nicht (glaube ich steht in der Doku.).
Muß das nicht mit SysFreeString(strVar) wieder freigegeben werden?

Danke freak und Kiffi für die Listen. Besonders die Vollständige ist zum
Fehler finden sehr hilfreich. Wird langsam brauchbar der PB-Disphelper.

Das mit der automatischen Variablenzuteilung wird wohl doch nicht so
einfach zu lösen sein

Gruß schic

Beitrag von **freak** » 02.05.2006 20:32

schic hat geschrieben:Zu dem Unicode-Modus: Ich verstehe nicht wieso
Code: Alles auswählen
      strVar = Str(lZahl) + "Text"
      tmp\vt = #VT_BSTR
      tmp\bstrVal = @strVar
nicht funktioniert. Und das stört mich etwas. Und nicht zu vergessen
das Unicode-Zeug läuft unter Win9x nicht (glaube ich steht in der Doku.).
Muß das nicht mit SysFreeString(strVar) wieder freigegeben werden?

Der BSTR typ lässt sich zwar als unicode string lesen, es ist aber bei COM für
das marshalling (transfer von objekten zwischen Prozessen/Computern usw.) wichtig
das sie mit SysAllocString_() oder SysAllocStringLen_() erstellt wurden.

Wenn einfach nur ein unicode string verlangt wird (gibt es auch), dann ist das der typ LPOLESTR oder LPWSTR.

Das ist ganz einfach: Einfach einen unicode string erzeugen (mit PokeS(..., #PB_Unicode)),
und dann SysAllocString_() mit dem Pointer davon aufrufen. Das ergebnis von SysAllocString_()
ist dann ein korrekter BSTR string. (der orginal unicode string wird nicht mehr gebraucht)

Wann man SysFreeString_() braucht ist folgendermaßen:

- Beim Aufrufen einer Methode mit BSTR als parameter:
Der der die Methode aufruft muss hinterher SysFreeString_() aufrufen, nicht die Methode selber.

- BSTR wird von der Methode zurückgegeben: (Meistens übergibt man einen pointer, der dann mit einer BSTR variable gefüllt wird)
Die Methode erzeugt den String, SysFreeString() muss von dem Aufrufer
ausgeführt werden.

Zum Thema Unicode:
Es stimmt, wenn der Unicode Support an ist braucht man unter Win9x den
Windows Layer für Unicode. Hab mich damit aber noch nicht auseinandergesetzt.

Man braucht aber für die Ansi->Uni konvertierung mit PB4 keine extra funktion mehr,
geht alles mit PeekS/PokeS und den entsprechenden Flags.

schic · Beitrag von **schic** » 02.05.2006 20:54

Dank für die Ausführiche Erklärung - bin ich wieder schlauer

freak hat geschrieben: Man braucht aber für die Ansi->Uni konvertierung mit PB4 keine extra funktion mehr,
geht alles mit PeekS/PokeS und den entsprechenden Flags.

aber nicht mit strVar = Str(lZahl) + "Text"!?

mk-soft · Beitrag von **mk-soft** » 02.05.2006 22:31

Hier zur veranschaulichung von type Variant\VT_BSTRr zum setzen und löschen

Code: Alles auswählen

; Unicode
Value.variant

Debug "Falsch - Speicherleck..."
For i = 1 To 5
  VariantInit_(Value)
  Value\vt = #VT_BSTR
  Value\bstrVal = SysAllocString_("Hallowelt")
  Debug "Adresse: " + Str(Value\bstrVal)
  ;VariantClear_(Value)
Next i

Debug "Richtig..."
For i = 1 To 5
  VariantInit_(Value)
  Value\vt = #VT_BSTR
  Value\bstrVal = SysAllocString_("Hallowelt")
  Debug "Adresse: " + Str(Value\bstrVal)
  VariantClear_(Value)
Next i

FF