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 |
