1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
| Function Query(requete As String, Optional NDF As String = "Q")
Dim Cnx As Object, Rst As Object
Dim NDF_Data As String
Dim Col_SQL As Integer, i As Long, j As Integer
On Error GoTo errhdlr
'NDF_Data = Activedocument.Path & "\" & NDF ' code pour Word
NDF_Data = IIf(NDF = "Q", ActiveWorkbook.Path & "\" & ActiveWorkbook.Name, NDF) ' Code pour XL
Set Cnx = CreateObject("ADODB.Connection")
With Cnx
.Provider = "MSDASQL"
.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"DBQ=" & NDF_Data & "; ReadOnly=False;"
.Open
End With
Set Rst = CreateObject("ADODB.Recordset")
If Left(requete, 6) = "SELECT" Then
Rst.Open requete, Cnx, 3 ' adOpenStatic
Query = Rst.RecordCount
Col_SQL = Rst.Fields.Count - 1
ReDim Ent(Col_SQL)
For i = 0 To Col_SQL
Ent(i) = Rst.Fields(i).Name
Next i
If Not Query = 0 Then
ReDim RcdSt(Col_SQL, Query - 1)
ReDim StRcd(Query - 1, Col_SQL)
Rst.movefirst
RcdSt = Rst.GetRows
For i = 0 To Query - 1
For j = 0 To Col_SQL
If Not IsNull(RcdSt(j, i)) And Not RcdSt(j, i) = "" Then
StRcd(i, j) = RcdSt(j, i)
End If
Next j
Next i
' ***********************************************************************
'Rst.MoveFirst
'Sheets(Pref).Range("X2").CopyFromRecordset Rst
' ***********************************************************************
End If
Else
Query = 1
Set Rst = Cnx.Execute(requete)
End If
Cnx.Close
Set Cnx = Nothing
Set Rst = Nothing
Exit Function
errhdlr:
If Not Rst Is Nothing Then
If Rst.State = 1 Then Rst.Close
End If
Set Rst = Nothing
If Not Cnx Is Nothing Then
If Cnx.State = 1 Then Cnx.Close
End If
Set Cnx = Nothing
MsgBox (Err.Description & vbCrLf & vbCrLf & "Vérifier la requête (ou son appel) : " & _
vbCrLf & requete)
End Function |
Partager