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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
| Private Sub UserForm_Initialize()
orderby2.Clear
orderby2.AddItem "Upward"
orderby2.AddItem "Downward"
orderby2.ListIndex = 0
Call PopulaCidades
Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)End Sub
Private Sub PopulaCidades() Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT DISTINCT CountryLocation FROM [database$]"
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With
Do While Not rst.EOF
If Not IsNull(rst(0).Value) Then
listcountry.AddItem rst(0).Value
End If
rst.MoveNext
Loop
Set rst = Nothing
conn.Close
End Sub
Private Sub PopulaListBox(ByVal countryoffice As String, _
ByVal projectlocation As String, _
ByVal fieldlocation As String, _
ByVal sicompany As String, _
ByVal srdcompany As String, _
ByVal prediction As String)
On Error GoTo TrataErro
Dim rst As ADODB.Recordset
Dim campo As Field
Dim myArray() As Variant
Dim i As Integer
Set rst = PreecheRecordSet(countryoffice, projectlocation, fieldlocation, sicompany, srdcompany, predictionmethod)
'prends le numero des choses enregistrés pour attribuer au listbox
listtotal.ColumnCount = rst.Fields.Count
'remplis le combobox avec les noms du champs
'reste le même indice
Dim indiceTemp As Long
indiceTemp = orderby.ListIndex
orderby.Clear
For Each campo In rst.Fields
orderby.AddItem campo.Name
Next
'recupere l'indice selectioné
orderby.ListIndex = indiceTemp
'mets les lignes du recordset dans un array si il y a lignes dans celui là
If Not rst.EOF And Not rst.BOF Then
myArray = rst.GetRows
'change linge par collune au away
myArray = Array2DTranspose(myArray)
'mets l'aways au listbox
listtotal.list = myArray
'ajoute la ligne de la colonne
listtotal.AddItem , 0
'remplis
For i = 0 To rst.Fields.Count - 1
listtotal.list(0, i) = rst.Fields(i).Name
Next i
'selectione le premier
listtotal.ListIndex = 0
Else
listtotal.Clear
End If
'mets a jour le label
If listtotal.ListCount <= 0 Then
lblMensagens.Caption = listtotal.ListCount & " Records found"
Else
lblMensagens.Caption = listtotal.ListCount - 1 & " Records found"
End If
' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
'conn.Close
TrataSaida:
Exit Sub
TrataErro:
Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End Sub
Private Function PreecheRecordSet(ByVal countryoffice1 As String, _
ByVal projectlocation1 As String, _
ByVal fieldlocation1 As String, _
ByVal sicompany1 As String, _
ByVal srdcompany1 As String, _
ByVal prediction1 As String) As Recordset
On Error GoTo TrataErro
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT * FROM [database$]"
'creer WHERE
'countryoffice
Call MontaClausulaWhere(countryoffice.Name, "CountryOffice", sqlWhere)
'ProjectLocation
Call MontaClausulaWhere(projectlocation.Name, "ProjectLocation", sqlWhere)
'FieldLocation
Call MontaClausulaWhere(fieldlocation.Name, "FieldLocation", sqlWhere)
'CountryLocation
For i = 1 To listcountry.ListCount
'verifica se o item está selecionado
If listcountry.Selected(i - 1) Then
'Monta a cláusula WHERE com OR
Debug.Print listcountry.list(i - 1) & " selected"
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " OR"
End If
sqlWhere = sqlWhere & " UCASE(CountryLocation) LIKE UCASE('%" & Trim(listcountry.list(i - 1)) & "%')"
End If
Next
'SICompany
Call MontaClausulaWhere(sicompany.Name, "SICompany", sqlWhere)
'SRDCompany
Call MontaClausulaWhere(srdcompany.Name, "SRDCompany", sqlWhere)
'PredictionMethod
Call MontaClausulaWhere(predictionmethod.Name, "PredictionMethod", sqlWhere)
'mescle string SQL avec WHERE
If sqlWhere <> vbNullString Then
sql = sql & " WHERE " & sqlWhere
End If
'mescle SQL avec ORDER BY
If orderby.ListIndex <> -1 Then
sqlOrderBy = " ORDER BY " & orderby.list(orderby.ListIndex, 0)
'direction
Select Case orderby2.ListIndex
Case Upward
sqlOrderBy = sqlOrderBy & " UP"
Case Downward
sqlOrderBy = sqlOrderBy & " DOWN"
End Select
sql = sql & sqlOrderBy
End If
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenForwardOnly, _
adLockBatchOptimistic
End With
Set rst.ActiveConnection = Nothing
'Ferme la conexion.
conn.Close
Set PreecheRecordSet = rst
Exit Function
TrataErro:
Set rst = Nothing
End Function
Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
sqlWhere = sqlWhere & " UCASE(" & NomeCampo & ") LIKE UCASE('%" & Trim(Me.Controls(NomeControle).Text) & "%')"
End If
End Sub
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant
If IsArray(avValues) Then
On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)
ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If
Array2DTranspose = avTransposed
Exit Function
ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function |
Remplissage du tableau initial
Répondre avec citation
Partager