PureBoard

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

Structure ObjType
  lpObj.IDispatch
  strObjNam.s
EndStructure

;- Globals
;Global pApp.IDispatch
Global pvResult.VARIANT
Global IID_NULL.GUID
Global LastError.l
Global LastMessage.s 
;}

;- Arrays Linked Lists
Global Dim varArr.VARIANT(0)
Global NewList ObjectList.ObjType()
;}

Procedure.l Ansi2Uni(ansistr.s) ; Converts normal (Ansi) string to Unicode
                                ; not needed if unicode is used 
  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 

Procedure.s Uni2Ansi(unicodestr.l) ; Converts Unicode to normal (Ansi) string
                                   ; not needed if unicode is used
  lenA = WideCharToMultiByte_(#CP_ACP, 0, unicodestr, -1, 0, 0, 0, 0);
  ansistr.s = Space(lenA)
  If (lenA > 0)
    WideCharToMultiByte_(#CP_ACP, 0, unicodestr, -1, @ansistr, lenA, 0, 0);
  EndIf
  ProcedureReturn ansistr
EndProcedure 


Procedure.l AutoWrap(autoTyp.l, *pDisp.IDispatch, name.s, nArgs.l); Args: DISPATCH_METHOD or DISPATCH_PROPERTYGET/PUT, Pointer to the Dispath Interface of the Parent-Object, name of the Child-Obj or Method or Property, Number of Arguments to pass
  dispID.l
  Exception.EXCEPINFO
  
  dp.DISPPARAMS
  dispidNamed = #DISPID_PROPERTYPUT
  
  ;Convert to Uni
  ptUniName = Ansi2Uni(name)
  Debug "getting IDs of " + name
  ;Get DISPID for name passed...
  ;GetIDsOfNames dient dazu, von dem angerufenen Objekt zu erfahren, ob es eine 
  ;bestimmte Funktion unterstützt. Dabei wird der Methodenname als text für die 
  ;Anfrage verwendet. unterstützt das Objekt die angefragte Funktion, so liefert 
  ;GetIDsOfNames eine id für diese Methode zurück. diese id wird benötigt, um die 
  ;gesuchte Funktion aufrufen zu können – hierzu dient die IDispatch-Funktion Invoke.
  ; ->http://msdn.microsoft.com/library/default.asp?url=/library/en-us/automat/html/ebbff4bc-36b2-4861-9efa-ffa45e013eb5.asp
  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!
  ;Invoke provides access To properties And methods exposed by an object.
  ; -> http://msdn.microsoft.com/library/default.asp?url=/library/en-us/automat/html/964ade8e-9d8a-4d32-bd47-aa678912a54d.asp
  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 ;the application needs to raise an 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

Procedure.l SetAppObj(app.s); init COM, get CLSID for Application
  hr = CoInitialize_(0); Initializes the COM library on the current thread and identifies 
                       ; the concurrency model As single-thread apartment (STA). 
                       ; Applications must initialize the COM library before they can 
                       ; call COM library functions -> http://msdn2.microsoft.com/en-us/library/ms678543.aspx
  If  hr <> #S_OK And hr <> #S_FALSE
    LastError = hr
    LastMessage = "Error CoInitialize: ErrorCode " + Hex(hr)
    End
  EndIf
  
  clsid.GUID
  hr = CLSIDFromProgID_(Ansi2Uni(app), @clsid); Looks up a CLSID in the registry, given a ProgID
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CLSIDFromProgID: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  
  ;MIDL_INTERFACE("00000000-0000-0000-C000-000000000046")
  ; typedef struct _GUID {
  ; unsigned long  Data1;
  ; unsigned short Data2;
  ; unsigned short Data3;
  ; unsigned Char  Data4[ 8 ];
  ; } GUID;
  IID_IUnknown.GUID ;GUID of the IUnknown COM interface. 
  IID_IUnknown\Data4[0] = $C0
  IID_IUnknown\Data4[7] = $46
  
  ;This function creates on the local system a single uninitialized 
  ;object of the class associated With a specified class identifier. 
  ; -> http://msdn2.microsoft.com/en-us/library/ms886232.aspx
  pUnk.IUnknown
  hr = CoCreateInstance_(@clsid, #Null, #CLSCTX_LOCAL_SERVER | #CLSCTX_INPROC_SERVER, @IID_IUnknown, @pUnk);
  ;IDispatch* pDispApp;
  ; MIDL_INTERFACE("00020400-0000-0000-C000-000000000046")
  IID_IDispatch.GUID
  IID_IDispatch\Data1 = $20400
  IID_IDispatch\Data4[0] = $C0
  IID_IDispatch\Data4[7] = $46
  
  hr = pUnk\QueryInterface(@IID_IDispatch, @*pApp.IDispatch);Returns a pointer to a specified interface on an object 
  
  ProcedureReturn *pApp
EndProcedure

Procedure.l SetComObj(lpParentObj, strObjectNam.s, lArgs.l); creating a COM-Object and store it in a LinkedList
   
  VariantInit_(@pvResult);
  hr = AutoWrap(#DISPATCH_PROPERTYGET, lpParentObj, strObjectNam, lArgs)
  If hr = #S_OK
    Debug strObjectNam + " o.k."
    AddElement(ObjectList())
    ObjectList()\lpObj = pvResult\pdispVal
    ObjectList()\strObjNam = strObjectNam
    ProcedureReturn pvResult\pdispVal
  Else
    Debug strObjectNam + " NOT o.k."
    LastError = hr
    LastMessage = "Error Get Object: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  
EndProcedure

Procedure SetObjNothing(*Object.IDispatch)
  If *Object
    *Object\Release()
  EndIf
EndProcedure 

Procedure ReleaseAllObjects(); releasing all Objects in the List, starting at the last Sub-Object
  LastElement(ObjectList())
  Repeat
    If ObjectList()\lpObj
      ObjectList()\lpObj\Release()
    EndIf
  Until PreviousElement(ObjectList()) = 0
  ClearList(ObjectList())
EndProcedure

Procedure XLPutCellsStrValue(*sheet.IDispatch, Row, Column, strTxt.s)
  Dim varArr.VARIANT(2) ;init the arguments to get the object Cells
  varArr(0)\vt = #VT_I4 ;Type of a 4-byte integer for Column
  varArr(0)\lVal = Column
  varArr(1)\vt = #VT_I4 ;Type of a 4-byte integer for Row
  varArr(1)\lVal = Row
  
  pvResult.VARIANT ;init the return-Variable for AutoWrap
  VariantInit_(@pvResult);
  hr = AutoWrap(#DISPATCH_PROPERTYGET, *sheet, "Cells", 2); sheet is the parent Object 
                                                          ; -> we need the Cells-Object
                                                          ; and get it with 2 arguments
                                                          ; Column an Row
                                                          ; Set pXlCells_x_y = *sheet.Cells(Row, Column)
  pXlCells_x_y.IDispatch = pvResult\pdispVal ; the return-value is a pointer to the object. 
                                             ; The pointer is in pdispVal. This object is 
                                             ; known only To implement IDispatch.
  Dim varArr.VARIANT(1) ;init the argument to put the property Value
  varArr(0)\vt = #VT_BSTR
  varArr(0)\bstrVal = Ansi2Uni(strTxt)
  AutoWrap(#DISPATCH_PROPERTYPUT,  pXlCells_x_y, "Value", 1); putting the property Value (strTxt) to the cells-object
                                                            ; -> pXlCells_x_y.Value = strTxt
  VariantClear_(varArr(0)) ; free varArr()
  
  SetObjNothing(pXlCells_x_y) ; release it at once, to save memory cause we may not need this cells-object any more
EndProcedure

pXlApp.IDispatch = SetAppObj("Excel.Application") ; create the object Excel -> Set pXlApp = Excel.Application
If pXlApp = 0
  Debug LastMessage
  End
EndIf

;{ make application visible ( 
Dim varArr.VARIANT(1)
varArr(0)\vt = #VT_I4 ;Variant-Value
varArr(0)\lVal = 1    ;for TRUE (=1)
AutoWrap(#DISPATCH_PROPERTYPUT, pXlApp, "Visible", 1); put the value "TRUE" to the property Visible -> pXlApp.Visible = True
VariantClear_(varArr(0))
;}

pXlBooks.IDispatch = SetComObj(pXlApp, "Workbooks", 0); get the Workbookslist-Object -> Set pXlBooks = pXlApp.Workbooks

;{ add a workbook, VBA-Code: pXlBooks.Add
pXlBook.IDispatch ;init the dispatch interface for the workbook
pvResult.VARIANT
VariantInit_(@pvResult);
AutoWrap(#DISPATCH_PROPERTYGET, pXlBooks, "Add", 0); call the method "Add" from Workbooks
pXlBook = pvResult\pdispVal
;}

pXlSheets.IDispatch = SetComObj(pXlBook, "Sheets", 0); getting the Sheetslist-Object -> Set pXlSheets = pXlBook.Sheets
Dim pXlSheet.IDispatch(9); we want 9 sheets so init an Array of 9 Dispatch-Interfaces
For i = 4 To 9 ; 3 sheets are already in the workbook so we start at 4
  ;{ add worksheets, VBA-Code: sheets.Add
  pvResult.VARIANT
  VariantInit_(@pvResult);
  AutoWrap(#DISPATCH_PROPERTYGET, pXlSheets, "Add", 0); call the method "Add" from Worksheets
  pXlSheet(i) = pvResult\pdispVal
  XLPutCellsStrValue(pXlSheet(i), i, 3, "blabla")
  ;}
Next

;getting the 3 standard-sheets as object
;cause we have inserted before them the count-numbers are the last
For i = 7 To 9
  varArr(0)\vt = #VT_I4 ;Variant-Value
  varArr(0)\lVal = i    ;for Item-Number
  pvResult.VARIANT
  VariantInit_(@pvResult);
  AutoWrap(#DISPATCH_PROPERTYGET, pXlSheets, "Item", 1) ; Set pXlSheet(i-6) = pXlSheets.Item(i)
  pXlSheet(i-6) = pvResult\pdispVal
Next

pvResult.VARIANT
VariantInit_(@pvResult);
AutoWrap(#DISPATCH_PROPERTYGET, pXlSheets, "Count", 0); numOfSheets = pXlSheets.Count
numOfSheets = pvResult\lVal
For i = 1 To numOfSheets
  pvResult.VARIANT
  VariantInit_(@pvResult);
  AutoWrap(#DISPATCH_PROPERTYGET, pXlSheet(i), "Name", 0) ; SheetNam$ = pXlSheet(i).Name
  SheetNam$ = Uni2Ansi(pvResult\bstrVal)
  For j = 1 To 10
    XLPutCellsStrValue(pXlSheet(i), j, 1, SheetNam$ + " Row " + Str(j))
  Next
Next

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

;AutoWrap(#DISPATCH_METHOD, pXlApp, "Quit", 0)

cleaningUp:
ReleaseAllObjects()
CoUninitialize_()

End

Code: Alles auswählen

sql1.s = "Select * From [adressen$]"
If DatabaseQuery(#Datenbank1, sql1) ; Ermittelt alle Einträge