vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
vb@rchiv Offline-Reader - exklusiv auf der vb@rchiv CD Vol.4  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2015
 
zurück
Rubrik: Datenbanken · ADO   |   VB-Versionen: VB609.05.08
Exceldatei mit ADO öffnen

Mit dieser Funktion lässt sich eine Excel-Tabelle auch dann via ADO-Zugriff öffnen und anzeigen, wenn im Tabellenname unzulässige Zeichen enthalten sind.

Autor:   Norbert GrimmBewertung:     [ Jetzt bewerten ]Views:  10.232 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Summer-Special bei Tools & Components!
Gute Laune Sommer bei Tools & Components
Top Summer-Special - Sparen Sie teilweise über 100,- EUR
Alle sev-Entwicklerkomponenten und Komplettpakete jetzt bis zu 25% reduziert!
zum Beispiel:
  • Developer CD nur 455,- EUR statt 569,- EUR
  • sevDTA 2.0 nur 224,30 EUR statt 299,- EUR
  •  
  • vb@rchiv   Vol.6 nur 18,70 EUR statt 24,95 EUR
  • sevCoolbar 3.0 nur 58,70 EUR statt 69,- EUR
  • - Werbung -Und viele weitere Angebote           Aktionspreise nur für kurze Zeit gültig

    In der Praxis werden Tabellennamen von Excel-Dateien oft individuell umbenannt. Dabei kommt es vor, dass sich im Namen für die SQL-Anweisung ungültige Zeichen befinden.

    Die Funktion Ado_XLS öffnet die Excel-Datei zunächst mit der Excel_Application, ermittelt die Tabellen(namen) und korrigiert die Tabellennamen, falls sich ein ungültiges Zeichen darin befindet. Nach dem Schließen des Excel-Objects wird die Excel-Tabelle mit einem ADODB.Connection bzw. ADODB.Recordset geöffent und in einem MSHFlexGrid-Control angezeigt.

    Option Explicit
     
    Private Const cExcel      As String = "Excel.Application"
    Private Const cProvider   As String = "Microsoft.Jet.OLEDB.4.0;"
    Private Const cProviderEx As String = "Microsoft.Jet.OLEDB.4.0;" & _
                                          "Extended Properties=Excel 8.0"
     
    Private adoFlag As Boolean
    Private conFlag As Boolean          ' Connection.State [0, 1]
    Private cnMDB  As ADODB.Connection
    Private adoRS  As ADODB.Recordset
    ' Parameter :
    ' xlPath    : DateiName/Pfad der Excel_Datei
    '
    ' Rückgabewert: 0 wenn kein Fehler aufgetreten
    '               sonst Fehlernummer
    Private Function Ado_XLS(ByVal xlPath As String) As Long
      Dim Flag        As Boolean
      Dim C           As Long
      Dim D           As Long
      Dim I           As Long
      Dim J           As Long
      Dim K           As Long
      Dim L           As Long
      Dim P           As Long
      Dim Ret         As Long
      Dim T           As Long
      Dim UB          As Long
      Dim ZE          As Long
     
      Dim vTName()    As Variant
      Dim V           As Variant
      Dim vName       As Variant
      Dim vTmp        As Variant
      Dim vTab        As Variant
      Dim vVal        As Variant
      Dim vZeich()    As Variant
      Dim sTabelle    As String
      Dim sName       As String
      Dim strSQL      As String
      Dim sFile       As String
      Dim errMsg      As String
     
      Dim xlApp           As Object
      Dim xlSheet         As Object   ' Excel.Workbook
      Dim xlRange         As Object   ' Excel.Range
      Dim nCols           As Long     ' Anzahl der Spalten der Tabelle
     
      ' Fehlerroutine
      On Error GoTo Err_XLS
     
      ' Schließen, wenn bereits geöffnet war
      If conFlag Then cnMDB.Close
     
      ' Excel Application öffnen
      Set xlApp = CreateObject(cExcel)
      Set xlSheet = xlApp.Workbooks.Open(xlPath)
     
      ' TabellenAnzahl u. -Namen ermitteln
      With xlSheet
        D = .Worksheets.Count
        For I = 1 To D
          ReDim Preserve vTName(I)
          vName = .Worksheets(I).Name
          sName = ""
     
          ' ungültige Zeichen in SQL-Anweisung
          vZeich = Array(Chr(32), "!", "#", ",")
          UB = UBound(vZeich)
          For K = 0 To UB
            P = InStr(1, vName, vZeich(K))
            ' ungültiges Zeichen gefunden
            If P Then Exit For
          Next K
     
          ' -> check gültigen Bezeichner für SQL
          ' (entferne chr(32), Komma, usw.)
          ' z.B: "Geb. 109, 2008"
          If P Then
            L = Len(vName)
            For J = 1 To L
              V = Mid(vName, J, 1)
              ZE = 0
              Select Case V
                Case vZeich(0)
                  ZE = -1         ' Zeichen entfernen
                Case vZeich(1)    ' !
                  ZE = -1
                Case vZeich(2)    ' #
                  ZE = -1
                Case vZeich(3)    ' ,
                  V = "."         ' ersetze
              End Select
              ' Name mit gültigen Zeichen generieren (bilden)
              If ZE = 0 Then sName = sName & V
            Next J
     
            If Len(sName) > 0 Then
              If vName <> sName Then
                .Worksheets(I).Name = sName
                Flag = True            ' Änderungs_Flag setzen
              End If
            End If
          End If
     
          ' -> SQL-Check
          vTName(I) = .Worksheets(I).Name
        Next I
      End With
     
      ' Tabelle auswählen, wenn >1
      T = 1
      If D > 1 Then
        vTmp = vTmp & vbCr
        For I = 1 To D
          vTmp = vTmp & I & " : " & vTName(I) & vbCr
        Next I
        vTab = InputBox(vTmp, "Excel_Tabelle auswählen", T)
        If Len(vTab) > 0 Then
          T = Val(vTab)
          If T = 0 Then T = 1
          If T > D Then T = D
        End If
      End If
     
      sTabelle = vTName(T)
      Set xlRange = xlSheet.Worksheets(T).Cells(1, 1).CurrentRegion
      With xlRange
        nCols = .Columns.Count - 1
        ' default
        If nCols <= 0 Then nCols = 10
        ReDim vCap(nCols)
     
        ' Einlesen Caption
        For J = 1 To nCols
          vVal = .Cells(1, J).Value
          If Len(vVal) > 0 Then
            vCap(J) = vVal
          Else
            vCap(J) = "F" & J
          End If
        Next J
      End With
      Me.lblHFlex.Caption = sTabelle
     
      ' Application schließen
      If Flag Then
        ' Änderung an TabellenName speichern
        xlSheet.Save
      End If
      xlApp.Quit
      Set xlApp = Nothing
     
      ' Initialisiere ADO_Object
      Set adoRS = New ADODB.Recordset
      Set cnMDB = New ADODB.Connection
     
      '1. Die Parameter des Connection_Objekts festlegen.
      With cnMDB
        .Provider = cProvider
        .Properties("Extended Properties") = "Excel 8.0"
        .Open xlPath
        ' Status_Flag
         conFlag = .State
      End With
     
      ' Optionen [SQL]
      strSQL = "SELECT * FROM [" & sTabelle & "$]"
     
      '2. Recordset_Object
      With adoRS
        .ActiveConnection = cnMDB
        .CursorLocation = adUseClient
        '.CursorType = adOpenKeyset  ' alternativ
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic ' Daten werden erst beim Update gesperrt
        .Open strSQL
        adoFlag = .State ' Status_Flag
      End With
     
      ' MSHFlexGrid   : nur lesen
      ' oder DataGrid : lesen, schreiben
      With Me.HFlex1
        .Redraw = False
        Set .DataSource = adoRS
        C = .Cols - 1
        .Row = 0
        For I = 0 To C
          .Col = I
          If Len(.Text) = 0 Then
            If I <= UBound(vCap) Then .Text = vCap(I)
          End If
          .CellFontBold = True
        Next I
        .Redraw = True
      End With
     
      P = InStrRev(xlPath, "\")
      P = P + 1
      sFile = Mid(xlPath, P)
     
      ' VB.Label
      Me.lblHFlex.Caption = "Quelle: " & sFile
     
    Exit_XLS:
      Ado_XLS = Ret
      Exit Function
     
    Err_XLS:
      With Err
        Ret = .Number
        errMsg = .Description
        .Clear
      End With
      If conFlag Then
        conFlag = False
        cnMDB.Close ' Datei freigeben
      End If
      MsgBox Ret & vbCr & errMsg
      Resume Exit_XLS
    End Function

    Dieser Tipp wurde bereits 10.232 mal aufgerufen.

    Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

    Über diesen Tipp im Forum diskutieren
    Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

    Neue Diskussion eröffnen

    nach obenzurück


    Anzeige

    Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
    (einschl. Beispielprojekt!)

    Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
    - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
    - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
    Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
     
       

    Druckansicht Druckansicht Copyright ©2000-2015 vb@rchiv Dieter Otter
    Alle Rechte vorbehalten.
    Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

    Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel