disphelper in PB: COM-Programmierung leicht gemacht

schic · Beitrag von **schic** » 30.04.2006 12:23

CoInitialize_(0)

habe ich vergessen am Beginn zu setzen-
Bei PB 3.94 gibt´s keinen Fehler bei PB 4 schon...

______
schic

Beitrag von **Kiffi** » 30.04.2006 12:31

schic hat geschrieben:
Code: Alles auswählen
CoInitialize_(0)

danke für Deine schnelle Antwort! Jetzt funktioniert's auch bei mir unter 3.94

schic hat geschrieben:Bei PB 3.94 gibt´s keinen Fehler bei PB 4 schon...

öhm,

den invalid memory-access habe ich unter 3.94 bekommen.
Unter PB4 lässt sich der Code erst gar nicht starten, da bei dieser Zeile:

Code: Alles auswählen

  dp\rgvarg = @varArr(0) ;ArgsArr;pArgs;*var;

ein Syntax-Error gemeldet wird.

Grüße ... Kiffi

schic · Beitrag von **schic** » 30.04.2006 12:42

varArr(0) ist in PB 3.94 immer Global
in PB 4 nicht ->
Global Dim varArr.Variant(0)

Gruß schic

schic · Beitrag von **schic** » 30.04.2006 15:06

habe das Ganze mal für PB 4 geändert (Compileroptionen:
Create Unicode Exe). Ist sehr praktisch wenn man Doubles
zurückbekommt wie bei dem Summenwert demonstriert.

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, not necessary, only for information 
  #VT_EMPTY = 0             ; No value was specified. If an optional argument to an Automation method is left blank, do not pass a VARIANT of type VT_EMPTY. Instead, pass a VARIANT of type VT_ERROR with a value of DISP_E_PARAMNOTFOUND.
  #VT_NULL = 1              ; A propagating null value was specified. (This should not be confused with the null pointer.) The null value is used for tri-state logic, as with SQL.
  #VT_I2 = 2                ; A 2-byte integer value is stored in iVal.
  #VT_I4 = 3                ; A 4-byte integer value is stored in lVal.
  #VT_R4 = 4                ; An IEEE 4-byte real value is stored in fltVal.
  #VT_R8 = 5                ; An 8-byte IEEE real value is stored in dblVal.
  #VT_CY = 6                ; A currency value was specified. A currency number is stored as 64-bit (8-byte), two's complement integer, scaled by 10,000 to give a fixed-point number with 15 digits to the left of the decimal point and 4 digits to the right. The value is in cyVal.
  #VT_DATE = 7              ; A value denoting a date and time was specified. Dates are represented as double-precision numbers, where midnight, January 1, 1900 is 2.0, January 2, 1900 is 3.0, and so on. The value is passed in date.
  #VT_BSTR = 8              ; A string was passed; it is stored in bstrVal. This pointer must be obtained and freed by the BSTR functions, which are described in Conversion and Manipulation Functions. 
  #VT_DISPATCH = 9          ; A pointer to an object was specified. The pointer is in pdispVal. This object is known only to implement IDispatch. The object can be queried as to whether it supports any other desired interface by calling QueryInterface on the object. Objects that do not implement IDispatch should be passed using VT_UNKNOWN.
  #VT_ERROR = 10            ; An SCODE was specified. The type of the error is specified in scodee. Generally, operations on error values should raise an exception or propagate the error to the return value, as appropriate.
  #VT_BOOL = 11             ; A 16 bit Boolean (True/False) value was specified. A value of 0xFFFF (all bits 1) indicates True; a value of 0 (all bits 0) indicates False. No other values are valid.
  #VT_VARIANT = 12          ; Invalid. VARIANTARGs must be passed by reference.
  #VT_UNKNOWN = 13          ; A pointer to an object that implements the IUnknown interface is passed in punkVal.
  #VT_DECIMAL = 14          ; Decimal variables are stored as 96-bit (12-byte) unsigned integers scaled by a variable power of 10. VT_DECIMAL uses the entire 16 bytes of the Variant.
  #VT_I1 = 16               ; A 1-byte character value is stored in cVal.
  #VT_UI1 = 17              ; An unsigned 1-byte character is stored in bVal.
  #VT_UI2 = 18              ; An unsigned 2-byte integer value is stored in uiVal.
  #VT_UI4 = 19              ; An unsigned 4-byte integer value is stored in ulVal.
  #VT_I8 = 20               ; A 8-byte integer value is stored in llVal.
  #VT_UI8 = 21              ; An unsigned 8-byte integer value is stored in ullVal.
  #VT_INT = 22              ; An integer value is stored in intVal.
  #VT_UINT = 23             ; An unsigned integer value is stored in uintVal.
  #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  ; with PB 4 not necessary only for information
  *pvRecord.l
  *pRecInfo.IRecordInfo
EndStructure

Structure xVariant  ; with PB 4 not necessary only for information (not sure if all types are correct)
  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;.Variant
    *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   ; with PB 4 not necessary only for information
;   *rgvarg.l               ;array of arguments Variant
;   ;*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.Variant
Global IID_NULL.GUID
;}

Global Dim varArr.Variant(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)
  ptUniName = @name
  Debug "getting IDs of " + name
  ;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


CoInitialize_(0)

; get application object
CLSID.GUID 
hr = CLSIDFromProgID_(@"Excel.Application", @CLSID)
Debug "hr CLSIDFromProgID: " + Hex(hr)
Debug CLSID\data1 ;148736 for Excel

pCf.IClassFactory

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)
; REGDB_E_KEYMISSING 	        0x80040152 	Could not find the key in the registry
; REGDB_E_INVALIDVALUE 	      0x80040153 	Invalid value For registry
; REGDB_E_CLASSNOTREG 	      0x80040154 	Class not registered
; REGDB_E_IIDNOTREG 	        0x80040155 	Interface not registered
; REGDB_E_BADTHREADINGMODEL 	0x80040156 	Threading model Entry is not valid
; CO_E_NOTINITIALIZED	        0x800401F0

If hr = 0
  riid.GUID
  riid\data1 = $20400
  riid\data4[0] = $C0
  riid\data4[7] = $46
  
  pApp.IDispatch
  hr = pCf\CreateInstance(#Null, @riid, @pApp)
  Debug "hr CreateInstance: " + Hex(hr)
  ; S_OK 	                      00000000 	0
  ; S_FALSE 	                  00000001 	1
  ; E_PENDING 	                8000000A 	2147483658
  ; E_NOTIMPL 	                80004001 	2147500033
  ; E_NOINTERFACE 	            80004002 	2147500034 The object that ppvObject points to does not support the interface identified by riid.
  ; E_POINTER 	                80004003 	2147500035
  ; E_ABORT 	                  80004004 	2147500036
  ; E_FAIL 	                    80004005 	2147500037
  ; E_UNEXPECTED 	              8000FFFF 	2147549183
  ; CLASS_E_NOAGGREGATION 	    80040110 	2147746064 The pUnkOuter parameter was non-NULL and the object does not support aggregation
  ; CLASS_E_CLASSNOTAVAILABLE 	80040111 	2147746065
  ; CLASS_E_NOTLICENSED 	      80040112 	2147746066
  ; E_ACCESSDENIED 	            80070005 	2147942405
  ; E_HANDLE 	                  80070006 	2147942406
  ; E_OUTOFMEMORY 	            8007000E 	2147942414
  ; E_INVALIDARG 	              80070057 	2147942487
  pCf\Release()
EndIf

;{ make application visible
Dim varArr.Variant(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.Variant
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 like this with VBA
;Get Range object for the Range A1:O15...
pXlRange.IDispatch
varArr(0)\vt = #VT_BSTR
varArr(0)\bstrVal = @"A1:O15"
pvResult.Variant
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.Variant
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 sum of Range to single cell in row 16, column 15, VBA-Code: Set pXlCells16_15 = Cells(4, 15): pXlCells16_15.FormulaLocal = "=SUMME(A1:O15)"
;arguments for column and row, cells(row,column)
;take care! arguments are handeled reverse
Dim varArr.Variant(2)
varArr(0)\vt = #VT_I4
varArr(0)\lVal = 15

varArr(1)\vt = #VT_I4
varArr(1)\lVal = 16
;get cell-object
pXlCells16_15.IDispatch
pvResult.Variant
VariantInit_(@pvResult)
If AutoWrap(#DISPATCH_PROPERTYGET, pXlSheet, "Cells", 2) = 0
  pXlCells16_15 = pvResult\pdispVal
EndIf

;set value
Dim varArr.Variant(1)
varArr(0)\vt = #VT_BSTR
varArr(0)\bstrVal = @"=SUMME(A1:O15)"
AutoWrap(#DISPATCH_PROPERTYPUT,  pXlCells16_15, "FormulaLocal", 1)
;}

;{ get the value of the sum
VariantInit_(pvResult)
AutoWrap(#DISPATCH_PROPERTYGET,  pXlCells16_15, "Value", 0)
Debug pvResult\vt
Debug "sum of A1:O15 = " + StrQ(pvResult\dblVal)
;}

;{ 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 16, column 15, VBA-Code: pXlCells16_15.Interior.ColorIndex = 36
pXlInterior.IDispatch
VariantInit_(@pvResult)
AutoWrap(#DISPATCH_PROPERTYGET, pXlCells16_15, "Interior", 0)
pXlInterior = pvResult\pdispVal

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

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

If pXlCells16_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

schic · Beitrag von **schic** » 30.04.2006 15:24

wenn ich versuche das Holen des Application-Handles in eine
Procedure zu packen kann ich auf das App-Objekt nicht
mehr zugreifen:

Code: Alles auswählen

Procedure SetAppObj(app.s, pApp.IDispatch)

CoInitialize_(0)

; get application object
CLSID.GUID 
hr = CLSIDFromProgID_(@app, @CLSID)
Debug "hr CLSIDFromProgID: " + Hex(hr)
Debug CLSID\data1 ;148736 for Excel

pCf.IClassFactory

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)
; REGDB_E_KEYMISSING 	        0x80040152 	Could not find the key in the registry
; REGDB_E_INVALIDVALUE 	      0x80040153 	Invalid value For registry
; REGDB_E_CLASSNOTREG 	      0x80040154 	Class not registered
; REGDB_E_IIDNOTREG 	        0x80040155 	Interface not registered
; REGDB_E_BADTHREADINGMODEL 	0x80040156 	Threading model Entry is not valid
; CO_E_NOTINITIALIZED	        0x800401F0

If hr = 0
  riid.GUID
  riid\data1 = $20400
  riid\data4[0] = $C0
  riid\data4[7] = $46
  
  ;pApp.IDispatch
  hr = pCf\CreateInstance(#Null, @riid, @pApp)
  Debug "hr CreateInstance: " + Hex(hr)
  ; S_OK 	                      00000000 	0
  ; S_FALSE 	                  00000001 	1
  ; E_PENDING 	                8000000A 	2147483658
  ; E_NOTIMPL 	                80004001 	2147500033
  ; E_NOINTERFACE 	            80004002 	2147500034 The object that ppvObject points to does not support the interface identified by riid.
  ; E_POINTER 	                80004003 	2147500035
  ; E_ABORT 	                  80004004 	2147500036
  ; E_FAIL 	                    80004005 	2147500037
  ; E_UNEXPECTED 	              8000FFFF 	2147549183
  ; CLASS_E_NOAGGREGATION 	    80040110 	2147746064 The pUnkOuter parameter was non-NULL and the object does not support aggregation
  ; CLASS_E_CLASSNOTAVAILABLE 	80040111 	2147746065
  ; CLASS_E_NOTLICENSED 	      80040112 	2147746066
  ; E_ACCESSDENIED 	            80070005 	2147942405
  ; E_HANDLE 	                  80070006 	2147942406
  ; E_OUTOFMEMORY 	            8007000E 	2147942414
  ; E_INVALIDARG 	              80070057 	2147942487
  pCf\Release()

Dim varArr.Variant(1)
varArr(0)\vt = #VT_I4
varArr(0)\lVal = 1
AutoWrap(#DISPATCH_PROPERTYPUT, pApp, "Visible", 1)
VariantClear_(varArr(0))

  ProcedureReturn hr
EndIf

EndProcedure


pXlApp.IDispatch
hr = SetAppObj("Excel.Application", @pXlApp)
Debug hr

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

pXlApp\Release()

aus der Procedure klappt das PropertyPut Visible, aber aus der Hauptanwendung nicht mehr.

Weiß jemand was da falsch ist?

Gruß schic

mk-soft · Beitrag von **mk-soft** » 30.04.2006 18:14

@schic,
Dein AutoWrap ist Klasse

Habe mein CreateObject für dein letztes Problem eingebunden.

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


;{-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  ; 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

;{-Globals
Global pvResult.Variant
Global IID_NULL.GUID
;}

Global Dim varArr.Variant(0)

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

; Globale Variablen

Global LastError.l
Global LastMessage.s

Procedure CreateObject(Object.s)

  LastError = 0
  LastMessage = ""
  
  hr = CoInitialize_(0)
  If  hr <> #S_OK And hr <> #S_FALSE
    LastError = hr
    LastMessage = "Error CoInitialize: ErrorCode " + Hex(hr)
    End
  EndIf
  
  CLSID.GUID
  hr = CLSIDFromProgID_(Object, @CLSID)
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CLSIDFromProgID: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  
  hr = CoGetClassObject_(@CLSID, #CLSCTX_LOCAL_SERVER, #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 AutoWrap(autoTyp.l, *pDisp.IDispatch, name.s, nArgs.l)
  dispID.l
  exception.EXCEPINFO
 
  dp.DISPPARAMS
  dispidNamed = #DISPID_PROPERTYPUT
 
  ;Convert to Uni
  ;ptUniName = Ansi2Uni(name)
  ptUniName = @name
  Debug "getting IDs of " + name
  ;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

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

*pXlApp.IDispatch = CreateObject("Excel.Application")
If *pXlApp = 0
  Debug LastMessage
  End
EndIf


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

*pXlApp\Release() 


;- 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

FF

ts-soft · Beitrag von **ts-soft** » 30.04.2006 18:42

Ich erhalte nur:

Debugger Output hat geschrieben:Error CLSIDFromProgID: ErrorCode 800401F3

schic · Beitrag von **schic** » 30.04.2006 18:53

@mk-soft

Danke - perfekt
weiß zwar noch nicht was ich falsch gemacht habe, aber werde es rausfinden

@ts-soft
Compileroptionen auf Unicode-Exe stellen, dann müßt´s laufen

ts-soft · Beitrag von **ts-soft** » 30.04.2006 18:54

>> Compileroptionen auf Unicode-Exe stellen, dann müßt´s laufen
danke, sieht schon ganz anders aus

schic · Beitrag von **schic** » 30.04.2006 19:16

Habe auch noch ein Problem mit dem Unicode-Zeugs.
Will in dem SafeArray einige Text-Teile haben.

Code: Alles auswählen

ProcedureDLL.l Ansi2Uni(ansistr.s) ; Converts normal (Ansi) string to Unicode
  lenA.l = Len(ansistr)
  lenW = MultiByteToWideChar_(#CP_ACP, 0, ansistr, lenA, 0, 0)
  If (lenW > 0) ; Check whether conversion was successful
    unicodestr = SysAllocStringLen_(0, lenW)
    MultiByteToWideChar_(#CP_ACP, 0, ansistr, lenA, unicodestr, lenW)
    result = unicodestr
    ProcedureReturn result
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

...

Code: Alles auswählen

;Fill safearray with some values...
Dim indices.l(1)
tmp.Variant
For i = 1 To 15
  For j = 1 To 15
    ;Create entry value for (i,j)
    tmp\vt = #VT_I4
    tmp\lVal = i*j
    If j = 7
      tmp\vt = #VT_BSTR
      txt.s = Str(i*j) + " blabla"
      tmp\bstrVal = Ansi2Uni(txt)
      Debug "tmp\bstrVal: " + Str(tmp\bstrVal)
    EndIf
    ;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

...

In PB 3.94 geht das mit tmp\bstrVal = Ansi2Uni(txt).
In PB 4 überblicke ich das mit den Unicode-Strings noch nicht so ganz

Die Zellen in Spalte 7 haben jedenfalls nur das erste Zeichen.