PureBoard

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

Wie lese ich einen Tabellennamen einer Datenbank (Excel)aus?

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

Seite 1 von 2

Verfasst: 23.07.2006 14:52
von schic
eine weitere Möglichkeit (nicht nur) die Blattnamen auszulesen:

Code: Alles auswählen

#CRLF = Chr(13)+Chr(10)

;- COM Stuff
;{- COM 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.l
  strObjNam.s
EndStructure

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

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

Procedure.l Ansi2Uni(ansistr) ; Converts normal (Ansi) string to Unicode
  ;lenA.l = Len(ansistr)
  lenA.l = MemoryStringLength(ansistr, #PB_Ascii)
  
  lenW = MultiByteToWideChar_(#CP_ACP, 0, ansistr, lenA, 0, 0);#CP_ACP
  If (lenW > 0) ; Check whether conversion was successful
    unicodestr = SysAllocStringLen_(0, lenW)
    result = MultiByteToWideChar_(#CP_ACP, 0, ansistr, lenA, unicodestr, lenW);#CP_ACP
    If result = 0
      Debug "Ansi2Uni(ansistr): " + Hex(result)
      ProcedureReturn 0
    EndIf
    ProcedureReturn unicodestr
  Else
    ProcedureReturn 0
  EndIf
EndProcedure 

Procedure.s Uni2Ansi(unicodestr.l) ; Converts Unicode to normal (Ansi) string
  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)
  dispID.l
  Exception.EXCEPINFO
  
  dp.DISPPARAMS
  dispidNamed = #DISPID_PROPERTYPUT
  
  ;Convert to Uni
  ptUniName = Ansi2Uni(@name)
  ;Get DISPID for name passed...
  ;Debug "trying name: " + name
  hr = *pDisp\GetIDsOfNames(IID_NULL, @ptUniName, 1, #LOCALE_USER_DEFAULT, @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_USER_DEFAULT, autoTyp, @dp, @pvResult, @Exception, #Null);#LOCALE_SYSTEM_DEFAULT
  If hr <> #S_OK
    Debug "error " + Str(hr) + " with name: " +  name
    LastError = hr
  EndIf
  Select hr
    Case #DISP_E_EXCEPTION
      MessageRequester(Uni2Ansi(@Exception\bstrSource), Uni2Ansi(@Exception\bstrDescription) + #CRLF + "Fehler Nr. " + Hex(hr) + " mit Objekt/Eigenschaft " + name, #MB_ICONERROR)
      Debug Uni2Ansi(@Exception\bstrSource)
      Debug "an Error occured in Excel " + Uni2Ansi(@Exception\bstrDescription)
    Case #S_OK
      
    Default
      MessageRequester("Excel Fehlermeldung", "Fehler Nr. " + Hex(hr) + " mit Objekt/Eigenschaft " + name, #MB_ICONERROR)
      Debug "Fehler Nr. " + Hex(hr) + " mit Objekt/Eigenschaft " + name
  EndSelect
  FreeMemory(ArgsArr)
  ProcedureReturn hr
EndProcedure

Procedure.l SetAppObj(app.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_(Ansi2Uni(@app), @clsid)
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CLSIDFromProgID: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  
  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 | #CLSCTX_INPROC_SERVER, #Null, @IID_IClassFactory, @pCf)
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CoGetClassObject: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  EndIf
  
  
  riid.GUID
  riid\Data1 = $20400
  riid\Data4[0] = $C0
  riid\Data4[7] = $46
  
  hr = pCf\CreateInstance(#Null, @riid, @*pApp.IDispatch)
  pCf\Release()
  If hr <> #S_OK
    LastError = hr
    LastMessage = "Error CreateInstance: ErrorCode " + Hex(hr)
    ProcedureReturn 0
  Else
    AddElement(ObjectList())
    ObjectList()\lpObj = *pApp
    ObjectList()\strObjNam = app
    ProcedureReturn *pApp
  EndIf
  
EndProcedure

Procedure.l SetComObj(lpParentObj, strObjectNam.s, lArgs.l)
  
  pvResult.VARIANT
  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()
  i = CountList(ObjectList())
  While i >= 0 ;ObjectList()
    SelectElement(ObjectList(), i)
    ; Debug "releasing " + ObjectList()\strObjNam
    ; Debug ObjectList()\lpObj
    If ObjectList()\lpObj
      *tmpObj.IDispatch = ObjectList()\lpObj
      *tmpObj\Release()
    EndIf
    i-1
  Wend
  ClearList(ObjectList())
EndProcedure

;{-Main
  
  File$ = "E:\test\Mappe1.xls"
  
  pXlApp.IDispatch = SetAppObj("Excel.Application") ;Excel.Application.10
  If pXlApp = 0
    End
  EndIf
  
  pXlBooks.IDispatch = SetComObj(pXlApp, "Workbooks", 0)
  
  varArr(0)\vt = #VT_BSTR
  varArr(0)\lVal = Ansi2Uni(@File$)
  AutoWrap(#DISPATCH_METHOD, pXlBooks, "Open", 1)
  VariantClear_(varArr(0))
  
  pXlBook.IDispatch = SetComObj(pXlApp, "ActiveWorkbook", 0)
  
  pXlSheets.IDispatch = SetComObj(pXlBook, "Worksheets", 0)
  
  VariantInit_(pvResult.VARIANT)
  AutoWrap(#DISPATCH_PROPERTYGET,  pXlSheets, "Count", 0)
  NumOfXlSheets = pvResult\lVal
  
  Dim pXlSheet.IDispatch(NumOfXlSheets)
  For i = 1 To NumOfXlSheets
    Dim varArr.VARIANT(1)
    varArr(0)\vt = #VT_I4
    varArr(0)\lVal = i
    pXlSheet(i) = SetComObj(pXlApp, "Worksheets", 1)
    VariantClear_(varArr(0))
    
    VariantInit_(pvResult.VARIANT) 
    AutoWrap(#DISPATCH_PROPERTYGET,  pXlSheet(i), "Name", 0)
    Nam$ = Uni2Ansi(pvResult\bstrVal)
    Debug Nam$
  Next
  
  AutoWrap(#DISPATCH_METHOD, pXlApp, "Quit", 0)
  ReleaseAllObjects()
  CoUninitialize_()
  LastError = 0
  ;}
Gruß
schic

Verfasst: 23.07.2006 15:02
von schic
mit

Code: Alles auswählen

Procedure.l XLGetCellsValue(*sheet.IDispatch, Row, Column)
  Shared tmpText$, qtmp.d
  
  Dim varArr.VARIANT(2)
  varArr(0)\vt = #VT_I4
  varArr(0)\lVal = Column
  varArr(1)\vt = #VT_I4
  varArr(1)\lVal = Row
  pXlCells_x_y.IDispatch
  pvResult.VARIANT
  VariantInit_(@pvResult);
  AutoWrap(#DISPATCH_PROPERTYGET, *sheet, "Cells", 2)
  pXlCells_x_y = pvResult\pdispVal
  
  VariantInit_(pvResult.VARIANT)
  AutoWrap(#DISPATCH_PROPERTYGET,  pXlCells_x_y, "Value", 0)
  Select pvResult\vt
    Case #VT_BSTR
      tmpText$ = Uni2Ansi(pvResult\bstrVal)
      result = @tmpText$
      
    Case #VT_R8
      qtmp = pvResult\dblVal
      result = @qtmp
      
  EndSelect
  
  VariantClear_(varArr(0))
  VariantClear_(varArr(1))
  VariantClear_(pvResult)
  
  SetObjNothing(pXlCells_x_y)
  
  ProcedureReturn result;tmpText$
EndProcedure



*tmp = XLGetCellsValue(pXlSheet(i), Zeile, Spalte)
Txt$ = PeekS(*tmp)

*tmp = XLGetCellsValue(pXlSheet(i), Zeile, Spalte)
dVal.d = PeekD(*tmp)
bekommst Du Zellenwerte aus Deinen Excel-Tabellen.
Ist schneller als mit ODBC

schic

Verfasst: 24.07.2006 15:18
von mpz
Danke schic,

mit dem Code kann wirklich was anfangen. Gibt es noch eine Möglichkeit die Anzahl der Spalten und Anzahl der Datensätz zu ermitteln? Ich habe eine einfache Möglichkeit gefunden, die aber sicherlich nicht optimal funktioniert und mit dem COM Parametern besser gehen wird:


Code: Alles auswählen

    a.l = 1
    Repeat
    *tmp = XLGetCellsValue(pXlSheet(i), 1, a)
    If *tmp
      ;Debug = PeekS(*tmp)
    Else
      Break
    EndIf 
       
    a=a+1
    ForEver  
    Debug "Spalten="+Str(a-1)


    a.l = 1
    Repeat
    *tmp = XLGetCellsValue(pXlSheet(i), a, 1)
    If *tmp
      ;Debug = PeekS(*tmp)
    Else
      Break
    EndIf 
       
    a=a+1
    ForEver     
    Debug "Datensätze="+Str(a-1)

Gruß Michael

Verfasst: 24.07.2006 16:52
von schic
VBA-Code für Anzahl der benutzten Zeilen:

Code: Alles auswählen

objSheet.UsedRange.Rows.Count
->
PB-Code

Code: Alles auswählen

pXlUsedRange.IDispatch = SetComObj(pXlSheet(2), "UsedRange", 0)
pxlRows.IDispatch = SetComObj(pXlUsedRange, "Rows", 0)
VariantInit_(pvResult.VARIANT)
AutoWrap(#DISPATCH_PROPERTYGET,  pxlRows, "Count", 0)
NumOfUsedRows = pvResult\lVal
Debug "NumOfUsedRows: " + Str(NumOfUsedRows)
siehe auch VBA-Hilfe -> UsedRange
Eine weitere Möglichkeit für letzte Zeile bzw. Spalte und auch sonst gute
Tipps gibt´s unter
http://www.schmittis-page.de/index.html ... ba/t17.htm

Gruß
schic

Verfasst: 24.07.2006 22:53
von mpz
Vielen herzlichen Dank,

jetzt habe ich alles was ich benötige und kann eine beliebige Exceldatei auslesen. Das es so viele Ansätze gibt, hätte ich nicht gedacht...

:allright:
Gruß Michael


VBA-Code für Anzahl der benutzten Spalten:

Code: Alles auswählen


    pXlUsedRange.IDispatch = SetComObj(pXlSheet(i), "UsedRange", 0) 
    pxlRows.IDispatch = SetComObj(pXlUsedRange, "Columns", 0) 
    VariantInit_(pvResult.VARIANT) 
    AutoWrap(#DISPATCH_PROPERTYGET,  pxlRows, "Count", 0) 
    NumOfUsedColumns = pvResult\lVal 
    Debug "NumOfUsedColumns: " + Str(NumOfUsedColumns)

Wer noch einen Tabellennamen einer Accessdatenbank über ODBC auslesen möchte (siehe meinen ersten Sourcecode) kann diese Funktion benutzen. Leider funktionierte Sie nur mit einer Accessdatei und nicht mit einer Exceldatei...

Code: Alles auswählen



#SQL_DRIVER_NOPROMPT = 0 
#sqlNoDataFound  = 100 

Global hEnv.l, Alloc.l, hDbc.l, hStmt.l,Ret.b,intCols.l 
Ergebnis.l = OpenLibrary(0,"ODBC32.dll") 


   strDataSource.s = "DBQ="+File$+";DRIVER={Microsoft Access Driver (*.mdb)}";*********************** 
   retcode=CallFunction(0,"SQLAllocEnv",@hEnv); 
   retcode=CallFunction(0,"SQLAllocConnect",hEnv,@hDbc); 
   retcode=CallFunction(0,"SQLDriverConnect",hDbc,#Null,strDataSource,Len(strDataSource),szConnStr,1024,@cbConnStr,#SQL_DRIVER_NOPROMPT) 
   retcode=CallFunction(0,"SQLAllocStmt",hDbc,@hStmt) 
   retcode=CallFunction(0,"SQLTables",hStmt,0,-3,0,-3,0,-3,"TABLE",Len("TABLE")); 
    
   Ret = CallFunction(0,"SQLFetch",hStmt)
   PrintN ("Ret = "+Str(ret))
    
    While Ret <> #sqlNoDataFound 
           Owner.s = Space(254) 
           Name.s = Space(254) 
           Ret = SQLGetData_(hStmt, 4, 1, Owner, 254, 0) 
           Ret = SQLGetData_(hStmt, 3, 1, Name, 254, 0) 
           If Owner = "TABLE" 
              Liste.s = Liste+Name+";" 
           EndIf 
      Ret = CallFunction(0,"SQLFetch",hStmt) 
    Wend
  PrintN ("Tabellennamen = "+liste)

PureBasic.asm[2482]: dd SM_idispatch error: undefined symbol

Verfasst: 23.09.2006 11:43
von Andreas_F
Wenn ich aus schic's Beispiel den Abschnitt -{-Main ... ;} in eine Procedure übertrage und diese dann aufrufe bekomme ich den o.a. Assembler-Fehler: "PureBasic.asm[2482]: dd SM_idispatch error: undefined symbol".

Was mache ich falsch?

Danke im voraus für jede konstruktive Hilfe
Andreas_F

Verfasst: 26.09.2006 18:38
von schic
wenn Du pXlSheets Global deklarierst geht´s.

Code: Alles auswählen


;...

Global Dim pXlSheets.IDispatch(1)

;...

Procedure main()
  
  File$ = "E:\test\Mappe1.xls"
  
  pXlApp.IDispatch = SetAppObj("Excel.Application") ;Excel.Application.10
  If pXlApp = 0
    End
  EndIf
  
  pXlBooks.IDispatch = SetComObj(pXlApp, "Workbooks", 0)
  If LastError: Goto releaseall: EndIf
  
  varArr(0)\vt = #VT_BSTR
  varArr(0)\lVal = Ansi2Uni(@File$)
  AutoWrap(#DISPATCH_METHOD, pXlBooks, "Open", 1)
  VariantClear_(varArr(0))
  If LastError: Goto releaseall: EndIf
  
  pXlBook.IDispatch = SetComObj(pXlApp, "ActiveWorkbook", 0)
  If LastError: Goto releaseall: EndIf
  
  pXlSheets.IDispatch = SetComObj(pXlBook, "Worksheets", 0)
  If LastError: Goto releaseall: EndIf
  
  VariantInit_(pvResult.VARIANT)
  AutoWrap(#DISPATCH_PROPERTYGET,  pXlSheets, "Count", 0)
  NumOfXlSheets = pvResult\lVal
  Debug "NumOfXlSheets: " + Str(NumOfXlSheets)
  If LastError: Goto releaseall: EndIf
  
  Dim pXlSheets.IDispatch(NumOfXlSheets)
  For i = 1 To NumOfXlSheets
    Dim varArr.VARIANT(1)
    varArr(0)\vt = #VT_I4
    varArr(0)\lVal = i
    pXlSheets(i) = SetComObj(pXlApp, "Worksheets", 1)
    VariantClear_(varArr(0))
    
    VariantInit_(pvResult.VARIANT)
    AutoWrap(#DISPATCH_PROPERTYGET,  pXlSheets(i), "Name", 0)
    Nam$ = Uni2Ansi(pvResult\bstrVal)
    If LastError: Goto releaseall: EndIf
    Debug Nam$
  Next
  
  releaseall:
  AutoWrap(#DISPATCH_METHOD, pXlApp, "Quit", 0)
  ReleaseAllObjects()
  CoUninitialize_()
  LastError = 0
  
EndProcedure

main()
________
schic

Verfasst: 26.09.2006 18:57
von schic
Das Problem tritt nur im Debug-Modus auf :-?
Scheint am Debugger zu liegen.

Gruß
schic

Verfasst: 29.09.2006 19:58
von Andreas_F
Danke schic, das war's!

Ja, das Problem tritt auch bei mir nur im Debug-Modus auf.

Vielen Dank, Andreas_F

Verfasst: 30.09.2006 02:54
von mk-soft
Gibt noch eine weitere möglichkeit. Ist gerade in ein anderen Thread.

http://www.purebasic.fr/german/viewtopi ... 6&start=10

FF :wink:
Alle Zeiten sind UTC+02:00
Seite 1 von 2

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de