XLDB v1.0.0

Table des procédures

1 - frmXLDB (frmXLDB.frm)
    1.1 - Private Sub cmdRq_Click

2 - modXLDB (modXLDB.bas)
    2.1 - Private Function bCreerFichierDsnODBCExcel
    2.2 - Public Function bCreerObjet
    2.3 - Public Function bFichierExiste
    2.4 - Public Function bIDE
    2.5 - Public Function bRqExcelODBC
    2.6 - Public Sub AfficherErreursADO
    2.7 - Public Sub AfficherMsgErreur



frmXLDB (frmXLDB.frm)


Option Explicit

Private Sub cmdRq_Click()
    
    Dim sSQL$, sLignes$, bFichierDSN As Boolean
    If Me.chkFichierDSN Then bFichierDSN = True
    sSQL = "Select * From [Article$]"
    Me.tbResultat.Text = sSQL
    If False = bRqExcelODBC(sSQL, sLignes, bFichierDSN) Then Exit Sub
    Me.tbResultat.Text = Me.tbResultat.Text & vbCrLf & sLignes
    
    sSQL = "Select * From [Famille$]"
    Me.tbResultat.Text = Me.tbResultat.Text & vbCrLf & sSQL
    If False = bRqExcelODBC(sSQL, sLignes, bFichierDSN) Then Exit Sub
    Me.tbResultat.Text = Me.tbResultat.Text & vbCrLf & sLignes
    
    ' Ne pas faire cette requête en mode debug dans l'IDE
    '  à cause du bug http://support.microsoft.com/kb/246167/en-us
    If bIDE() Then Exit Sub
    sSQL = "Select [Famille$].Famille, [Article$].*" & _
        " FROM [Famille$] INNER JOIN [Article$] ON" & _
        " [Famille$].CodeFamille = [Article$].CodeFamille;"
    Me.tbResultat.Text = Me.tbResultat.Text & vbCrLf & sSQL
    If False = bRqExcelODBC(sSQL, sLignes, bFichierDSN) Then Exit Sub
    Me.tbResultat.Text = Me.tbResultat.Text & vbCrLf & sLignes
    
End Sub


modXLDB (modXLDB.bas)


Option Explicit

' XLDB : Une base de données Excel via ODBC
' Par Patrice Dargenton
' patrice.dargenton@free.fr
' http://patrice.dargenton.free.fr/index.html
' www.vbfrance.com/listeauteur2.aspx?ID=1124
' Documentation : LisezMoi.html
' Version 1.0 du 13/02/2005

' Module ODBC

Private Const sTitreMsg$ = "XLDB"

' Pour pouvoir localiser la ligne ayant provoqué une erreur, mettre bTrapErr = False
Private Const bTrapErr As Boolean = True 'False

Public Function bRqExcelODBC(ByVal sSQL$, ByRef sLignes$, _
    Optional ByVal bFichierDSN As Boolean, _
    Optional ByVal sDelimiteurChamps$ = ";") As Boolean
    
    ' Executer une requête SQL sur une base de données Excel via ODBC
    '  et retourner les lignes visibles dans un TextBox
    
    If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0
    
    Dim sCheminCourant$, sCheminXLDB$, sConnexion$
    sCheminCourant = App.Path
    ' En fait, il n'est pas nécessaire d'indiquer un chemin absolu
    'sCheminXLDB = sCheminCourant & "\XLDB.xls"
    'sCheminXLDB = Replace(sCheminXLDB, "\", "\\")
    sCheminXLDB = "XLDB.xls"
    If False = bFichierExiste(sCheminCourant & "\XLDB.xls", _
        bPrompt:=True) Then Exit Function
    
    ' Faire une connexion directe sur le fichier Excel
    sConnexion = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & sCheminXLDB & ";" & _
        "Extended Properties=""Excel 8.0;"";"

    Dim sFichierDSN$
    If bFichierDSN Then
        ' En mode fichier .dsn, on peut paramétrer la connexion à l'extérieur du logiciel
        sFichierDSN = sCheminCourant & "\XLDB.dsn"
        If False = bFichierExiste(sFichierDSN) Then
            ' Il est très facile de créer un fichier .dsn par défaut
            If False = bCreerFichierDsnODBCExcel(sFichierDSN) Then Exit Function
        End If
        ' La chaîne de connexion est même plus simple
        sConnexion = "FILEDSN=" & sFichierDSN & ";"
    End If

    ' Liaison précoce (anticipée : à la compilation)
    'Dim oConn As New ADODB.Connection
    'Dim oRq As New ADODB.Recordset
    
    ' Laison tardive (à l'exécution)
    Dim oConn As Object, oRq As Object
    Dim bConnOuverte As Boolean, bRqOuverte As Boolean
    Const sClasseObjetADODBConnection$ = "ADODB.Connection"
    Const sClasseObjetADODBRecordset$ = "ADODB.Recordset"
    Const adModeRead& = 1
    Const adOpenForwardOnly& = 0

    If Not bCreerObjet(oConn, sClasseObjetADODBConnection) Then GoTo Fin
    If Not bCreerObjet(oRq, sClasseObjetADODBRecordset) Then GoTo Fin
    
    oConn.Mode = adModeRead
    oConn.Open sConnexion
    bConnOuverte = True
    oRq.CursorType = adOpenForwardOnly ' Lecture du fichier en avant seulement
    oRq.Open sSQL, oConn
    bRqOuverte = True
    If False = oRq.EOF Then
        
        ' ADODB.Recordset.GetString
        ' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/ado270/htm/mdmthgetstringmethod(recordset)ado.asp
        '- StringFormat : A StringFormatEnum value that specifies how the Recordset
        '  should be converted to a string. The RowDelimiter, ColumnDelimiter, and
        '  NullExpr parameters are used only with a StringFormat of adClipString.
        '- NumRows : Optional. The number of rows to be converted in the Recordset.
        '  If NumRows is not specified, or if it is greater than the total number of
        '  rows in the Recordset, then all the rows in the Recordset are converted.
        '- ColumnDelimiter : Optional. A delimiter used between columns, if specified,
        '  otherwise the TAB character.
        '- RowDelimiter : Optional. A delimiter used between rows, if specified,
        '  otherwise the CARRIAGE RETURN character.
        '- NullExpr : Optional. An expression used in place of a null value, if specified,
        '  otherwise the empty string.

        sLignes = oRq.GetString(, , sDelimiteurChamps)
        
        ' Convertir les codes Entrée (13) en Retour chariot pour la TextBox
        sLignes = Replace(sLignes, Chr$(vbKeyReturn), vbCrLf)
        
    End If
    oRq.Close: bRqOuverte = False
    oConn.Close: bConnOuverte = False
    bRqExcelODBC = True

Fin:
    If False = (oRq Is Nothing) And bRqOuverte Then oRq.Close
    If False = (oConn Is Nothing) And bConnOuverte Then oConn.Close
    Set oRq = Nothing
    Set oConn = Nothing
    Exit Function

Erreur:
    AfficherMsgErreur Err, "bRqExcelODBC", , "SQL : " & sSQL
    AfficherErreursADO oConn
    Resume Fin
    
End Function

Private Function bCreerFichierDsnODBCExcel(ByVal sCheminDSN$) As Boolean
    
    ' Créer un fichier .dsn ODBC pour Excel par défaut
    
    If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0
    
    Dim sCheminCourant$
    sCheminCourant = App.Path
    
    Dim lNumFichier&
    lNumFichier = FreeFile
    Open sCheminDSN For Output Access Write Lock Read Write As #lNumFichier
    Dim sODBC$
    
    sODBC = "MS-Excel"
    Print #lNumFichier, "[ODBC]"
    Print #lNumFichier, "DRIVER=Microsoft Excel Driver (*.xls)"
    Print #lNumFichier, "UID = admin"
    Print #lNumFichier, "UserCommitSync = Yes"
    Print #lNumFichier, "Threads = 3"
    Print #lNumFichier, "SafeTransactions = 0"
    Print #lNumFichier, "ReadOnly = 1"
    Print #lNumFichier, "PageTimeout = 5"
    Print #lNumFichier, "MaxScanRows = 8"
    Print #lNumFichier, "MaxBufferSize = 2048"
    Print #lNumFichier, "FIL=excel 8.0"
    Print #lNumFichier, "DriverId = 790"
    Print #lNumFichier, "DefaultDir=" & sCheminCourant
    Print #lNumFichier, "DBQ=" & sCheminCourant & "\XLDB.xls"

    Close #lNumFichier
    
    MsgBox "Le fichier .dsn pour la source ODBC " & sODBC & " a été créé" & vbLf & _
        "avec les chemins en local :" & vbLf & _
        sCheminDSN, vbExclamation, sTitreMsg
    bCreerFichierDsnODBCExcel = True

Fin:
    Exit Function

Erreur:
    AfficherMsgErreur Err, "bCreerFichierDsnODBCExcel"
    Close ' Fermer tous les fichiers ouverts
    Resume Fin

End Function

Public Sub AfficherMsgErreur(Erreur As Object, Optional sTitreFct$ = "", _
    Optional sInfo$ = "", Optional sDetailMsgErr$ = "")
    
    Const vbDefault% = 0
    If Screen.MousePointer <> vbDefault Then Screen.MousePointer = vbDefault
    Dim sMsg$
    If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct
    If sInfo <> "" Then sMsg = sMsg & vbCrLf & sInfo
    If Erreur.Number Then
        sMsg = sMsg & vbCrLf & "Err n°" & Str$(Erreur.Number) & " :"
        sMsg = sMsg & vbCrLf & Erreur.Description
    End If
    If sDetailMsgErr <> "" Then sMsg = sMsg & vbCrLf & sDetailMsgErr
    MsgBox sMsg, vbCritical, sTitreMsg
    
End Sub

Public Function bCreerObjet(ByRef oObjetQcq As Object, sClasse$) As Boolean

    On Error Resume Next
    Set oObjetQcq = CreateObject(sClasse)
    If Err <> 0 Then
        AfficherMsgErreur Err, "bCreerObjet", _
            "L'objet de classe [" & sClasse & "] ne peut pas être créé", vbCritical
        Err.Clear: Set oObjetQcq = Nothing: GoTo Fin
    End If
    bCreerObjet = True
    
Fin:
    On Error GoTo 0
    
End Function

Public Sub AfficherErreursADO(oConnexion As Object)

    If oConnexion Is Nothing Then Exit Sub

    Dim sMsg$, errDB As Object 'ADODB.Error
    For Each errDB In oConnexion.Errors
        sMsg = sMsg & "Erreur ADO : " & errDB.Description & vbLf
        sMsg = sMsg & "Numéro : " & errDB.Number & " (" & _
           Hex$(errDB.Number) & "), Détail : " & errDB.SQLState & vbLf
        MsgBox sMsg, vbCritical, sTitreMsg
    Next

End Sub

Public Function bIDE() As Boolean
  
  ' Retourner True si on est en mode debug dans l'IDE, sinon False (mode compilé .exe)
  '  (bIDE = IsIDE = Not IsCompiled)
  ' www.vbarchiv.net/forum/id2_i68236t68232.html
  On Error Resume Next
  Debug.Print 1 / 0
  bIDE = (Err <> 0)
  On Error GoTo 0
  
End Function

Public Function bFichierExiste(sFiltre$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean
    
    ' Retourner True si un fichier correspondant au filtre sFiltre est trouvé
    
    If sFiltre = "" Then Exit Function
    On Error Resume Next
    bFichierExiste = (Len(Dir$(sFiltre)) > 0)
    If Err.Number <> 0 Then bFichierExiste = False
    Err.Clear
    On Error GoTo 0
    
    If False = bFichierExiste And bPrompt Then _
        MsgBox "Impossible de trouver le fichier :" & vbLf & sFiltre, _
            vbCritical, sTitreMsg & " - Fichier introuvable"
    
End Function