Consultation ADO : problème lorsque base de donnée ouverte

Nico93

XLDnaute Nouveau
Bonjour,

J'utilise une fonction ADO trouvée sur Internet pour aller chercher des données dans un workbook fermé (que j'appellerai base).

Elle fonctionne parfaitement, le seul petit souci c'est que lorsque beaucoup d'utilisateurs travaillent en même temps avec cette fonction consultation, pour créer le recordset elle ouvre la base chez l'utilisateur. Cela crée une réaction en cascade chez tout le monde, qui fait qu'elle se retrouve ouverte en lecture seule chez tous les autres, et du coup impossible d'écrire via d'autres macro. Cela n'arrive pas tout le temps, mais il suffit que tout le monde bosse en même temps, ou que le serveur où est situé la base soit un peu lent et les consultations rentrent en conflit et forcent son ouverture chez tout le monde.

Je voudrais donc modifier la fonction pour que si le workbook où il y a la base est déjà sollicité, qu'il ne soit pas ouvert avec message d'erreur, ou alors ouvert en lecture seule par défaut puis refermée immédiatement.

Merci par avance de votre aide.

Voici la fonction :

Code:
Option Explicit


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function Array_Sort(ArrayList As Variant) As Variant
    Dim aCnt As Integer, bCnt As Integer
    Dim tempStr As String

    For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
        For bCnt = aCnt + 1 To UBound(ArrayList)
            If ArrayList(aCnt) > ArrayList(bCnt) Then
                tempStr = ArrayList(bCnt)
                ArrayList(bCnt) = ArrayList(aCnt)
                ArrayList(aCnt) = tempStr
            End If
        Next bCnt
    Next aCnt
    Array_Sort = ArrayList
End Function
 

joss56

XLDnaute Accro
Re : Consultation ADO : problème lorsque base de donnée ouverte

Bonjour,

J'ai toujours entendu dire qu'un fichier Excel en réseau c'était le pataquès assuré ! Aussi, j'utilise PALO pour l'utilisation en réseau d'une base de données accessible depuis Excel. PALO est gratuit. Je suis à ta disposition si tu souhaites en savoir plus.

Bonne journée

Jocelyn
 

Nico93

XLDnaute Nouveau
Re : Consultation ADO : problème lorsque base de donnée ouverte

Bonjour,

Merci de votre réponse. Je viens de mettre le système en place donc pas envie de tout changer. De manière générale cela fonctionne plutôt bien donc je n'ai pas à me plaindre. Simplement je souhaite corriger ce petit bug. Mais merci pour la suggestion.
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG