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 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
|
Option Compare Database
Option Explicit
Private Sub cbo_champ_AfterUpdate()
If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
Exit Sub ' l'un des champs est vide
End If
' initialise les étiquettes de l'opérateur
Me.lbl_Etiq1.Visible = True
Me.lbl_Etiq2.Visible = True
Me.lbl_Etiq3.Visible = True
Me.lbl_Etiq4.Visible = True
Me.lbl_Etiq5.Visible = True
Me.opt_Ope1.Visible = True
Me.opt_Ope2.Visible = True
Me.opt_Ope3.Visible = True
Me.opt_Ope4.Visible = True
Me.opt_Ope5.Visible = True
Me.txt_critere.Visible = True
Select Case lf_GetTypeField(Me.cbo_table, Me.cbo_champ) ' pour trouver le type du champs
Case Is = dbBoolean ' Booléen
Me.lbl_TypeChamp.Caption = "Oui/Non"
Me.lbl_Etiq1.Caption = "Oui"
Me.lbl_Etiq2.Caption = "Non"
Me.lbl_Etiq3.Caption = "Est Null"
Me.lbl_Etiq4.Caption = "N'est pas Null"
Me.lbl_Etiq5.Visible = False
Me.opt_Ope5.Visible = False
Me.txt_critere.Visible = False ' pas de critere
Case dbByte To dbBinary, dbLongBinary, dbGUID To dbVarBinary, dbNumeric To dbTimeStamp ' Numériques / date
Me.lbl_TypeChamp.Caption = "Numérique"
Me.lbl_Etiq1.Caption = "Etre égale ="
Me.lbl_Etiq2.Caption = "Etre supérieure >="
Me.lbl_Etiq3.Caption = "Etre inférieure <="
Me.lbl_Etiq4.Caption = "Etre différente <>"
Me.lbl_Etiq5.Visible = False
Me.opt_Ope5.Visible = False
Case dbText, dbMemo, dbChar ' texte / mémo
Me.lbl_TypeChamp.Caption = "Texte"
Me.lbl_Etiq1.Caption = "Etre strictement identique"
Me.lbl_Etiq2.Caption = "Commencer par la valeur"
Me.lbl_Etiq3.Caption = "Contenir la valeur"
Me.lbl_Etiq4.Caption = "Finir par la valeur"
Me.lbl_Etiq5.Caption = "Pas contenir la valeur"
Case Else
Me.lbl_TypeChamp.Caption = "Cas non prévu " & lf_GetTypeField(Me.cbo_table, Me.cbo_champ)
End Select
End Sub
Private Sub cbo_Query_AfterUpdate()
Function lf_GetQueryList()
' renseigne la table tbl_TemplstQry
Dim qrs As QueryDefs
Dim rst As Recordset
Dim strSql As String
Dim i As Integer
' efface la table temporaire
DoCmd.SetWarnings False
strSql = "Delete tbl_TempLstQry.*"
strSql = strSql + " FROM tbl_TempLstQry;"
DoCmd.RunSQL strSql
' rempli la table temporaire
Set qrs = CurrentDb.QueryDefs
Set rst = CurrentDb.OpenRecordset("tbl_TempLstQry")
For i = 0 To qrs.Count - 1
' Ne prend que le query USER_....
If qrs(i).Name Like "USER_*" Then
rst.AddNew
rst.Fields(0) = qrs(i).Name
rst.Update
End If
Next
lf_GetQueryList = rst.RecordCount
rst.Close
Set rst = Nothing
Set qrs = Nothing
DoCmd.SetWarnings True
End Function
Private Sub cbo_table_AfterUpdate()
Me.cbo_champ.RowSource = Me.cbo_table.Value
Me.cbo_champ.Requery
Me.cbo_champ.Value = Null
Me.lst_champs.RowSource = Me.cbo_table.Value
Me.lst_champs.Requery
End Sub
Private Sub cmd_LoadSQL_Click()
' charge la query
Dim strQuery As String
' élimine de cr lf (version 2000 et +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
' lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
' strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
Private Sub cmd_recherche_Click()
Dim strTable As String, strField As String, strCriteria As String, strSql As String
Dim Criter As Variant
If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
MsgBox "Vous devez renseigner la table et le champ pour effectuer une recherche !", vbExclamation + vbOKOnly, "Recherche"
Exit Sub
End If
Dim intTypChamp As Integer
Dim intOpeChamp As Integer
strTable = Me.cbo_table ' recupère le nom de la table
strField = Me.cbo_champ ' recupère le nom du champ
intTypChamp = lf_GetTypeField(strTable, strField) ' pour trouver le type du champs ...
intOpeChamp = Me.opt_Recherche
Select Case intTypChamp
Case dbBoolean ' bool
Select Case intOpeChamp
Case 1 ' oui
strCriteria = strTable & "." & strField & "=-1"
Case 2 ' non
strCriteria = strTable & "." & strField & "=0"
Case 3
strCriteria = "ISNULL(" & strTable & "." & strField & ")"
Case 4
strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
End Select
Case dbByte To dbBinary, dbLongBinary, dbBigInt To dbVarBinary, dbNumeric To dbTimeStamp
' traite les numeriques
If Not IsNull(Me.txt_critere) Then ' si le null n'est pas la valeur à traiter
strCriteria = Me.txt_critere
' traite la virgule si elle existe
If InStr(1, Me.txt_critere, ",") > 0 Then strCriteria = Replace(Me.txt_critere, ",", ".", 1)
'----------------------- pour les versions antérieure à la 2000
'If InStr(1, Me.txt_critere, ",") > 0 Then _
' strCriteria = Left(Me.txt_critere, InStr(1, Me.txt_critere, ",") - 1) _
' & "." & Right(Me.txt_critere, InStr(1, Me.txt_critere, ","))
'--------------------------------------------------------------
' type champ = date
If intTypChamp = dbDate And IsDate(Me.txt_critere) Then strCriteria = "#" & Me.txt_critere & "#"
' rajoute les dièses
End If
Select Case intOpeChamp ' numerique, date
Case 1 ' =
If IsNull(Me.txt_critere) Then
strCriteria = "ISNULL(" & strTable & "." & strField & ")"
Else
strCriteria = strTable & "." & strField & "=" & strCriteria
End If
Case 2 ' >=
strCriteria = strTable & "." & strField & ">=" & strCriteria
Case 3 ' <=
strCriteria = strTable & "." & strField & "<=" & strCriteria
Case 4 '<>
If IsNull(Me.txt_critere) Then
strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
Else
strCriteria = strTable & "." & strField & "<>" & strCriteria
End If
End Select
Case dbText, dbMemo, dbChar ' texte
Select Case intOpeChamp
Case 1 ' strictement egal
If IsNull(Me.txt_critere) Then
strCriteria = "ISNULL(" & strTable & "." & strField & ")"
Else
strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & """"
End If
Case 2 ' commence par
strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & "*"""
Case 3 ' contient
strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & "*"""
Case 4 ' fini par
strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & """"
Case 5 ' ne contient pas
If IsNull(Me.txt_critere) Then
strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
Else
strCriteria = "NOT " & strTable & "." & strField & " Like """ & Me.txt_critere & """"
End If
End Select
Case Else
MsgBox "Cas non prévu."
Exit Sub
End Select
' debut de selection des champs
Dim strChamps As String
Dim entCurrLigne As Integer
For entCurrLigne = 0 To Me.lst_champs.ListCount - 1
If Me.lst_champs.Selected(entCurrLigne) Then
strChamps = strChamps & "[" & Me.lst_champs.Column(0, entCurrLigne) & "], "
End If
Next entCurrLigne
If Len(strChamps) = 0 Then
strChamps = strTable & ".*"
Else
strChamps = Left(strChamps, Len(strChamps) - 2)
End If
' fin de selection des champs
' construit la requête sql
If Me.Opt_RechCourante And Not Len(Me.lst_resultat.RowSource) = 0 Then
If Not Me.lst_resultat.RowSource Like "*FROM " & strTable & "*" Then
MsgBox "La recherche précédente ne porte pas sur la même table que la recherche actuelle.", vbExclamation + vbOKOnly, "Erreur"
Exit Sub
End If
strSql = Left(Me.lst_resultat.RowSource, Len(Me.lst_resultat.RowSource) - 3)
strSql = strSql & " " & Me.cbo_operateur & " " & strCriteria & "));"
Else
' construit la rq sql
' construit la rq sql
strSql = "SELECT DISTINCTROW " & strChamps
strSql = strSql + " FROM " & strTable
strSql = strSql + " WHERE ((" & strCriteria & "));"
End If
Me.lst_resultat.RowSource = strSql ' affecte sql a lst_Resultat
Me.lst_resultat.Requery ' recalcule la liste
varqry = strSql
Me.txt_ChaineSQL.Value = strSql ' affiche le code
Me.lbl_nbRecord.Caption = IIf(Me.lst_resultat.ListCount _
<= 1, 0, Me.lst_resultat.ListCount - 1) & "/" & _
DCount(Me.cbo_champ, Me.cbo_table)
End Sub
Private Sub cmd_saveSQL_Click()
' controle d'existance
If IsNull(Me.txt_ChaineSQL) Then ' chaine vide
MsgBox "La chaine SQL est vide. Sauvegarde inutile.", vbExclamation + vbOKOnly, "erreur"
Exit Sub
End If
Dim strQuery As String
' demande le nom de la nouvelle query
strQuery = "USER_" & InputBox("Insérez le nom de la requête à créer (245 caractères max.):" _
& vbCrLf & "Ce nom sera précédé de USER_ .", "Nom de requête")
' vérifie la non présence
If IsNull(DLookup("Nom", "tbl_TempLstQry", "Nom=""" & strQuery & """")) Then
' sauve la query
CurrentDb.CreateQueryDef strQuery, Me.txt_ChaineSQL
lf_GetQueryList 'alimente la table pour cbo_query
Me.cbo_Query.Requery
MsgBox "Sauvegarde de " & strQuery & " effectuée.", vbInformation + vbOKOnly, "information"
Else
MsgBox "Ce nom de requête existe déjà.", vbExclamation + vbOKOnly, "Erreur"
End If
End Sub
Private Sub cmd_suppSQL_Click()
' charge la query
Dim strQuery As String
' élimine de cr lf (version 2000 et +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
' lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
' strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
Private Sub cmd_testSQL_Click()
' visualise la query
If IsNull(Me.txt_ChaineSQL) Then Exit Sub ' pas de chaine SQL
Me.lst_resultat.RowSource = Me.txt_ChaineSQL ' Affecte la chaine pour visualisation
Me.lst_resultat.Requery ' reffraichit la liste
End Sub
Private Sub Form_Open(Cancel As Integer)
' crée la liste des tables
If lf_GetTableList() = 0 Then
MsgBox "Pas de tables dans cette application .", vbInformation + vbOKOnly, "Erreur"
Cancel = True
End If
lf_GetQueryList 'alimente la table pour cbo_query
Me.cbo_Query.Requery 'raffraichit la liste
End Sub
Private Sub Form_Resize()
Opt_RechCourante_Click 'cache la zone liste et l'étiquette
End Sub
Private Sub lst_resultat_DblClick(Cancel As Integer)
Dim rst As Recordset
Dim strCriteria As String
Set rst = CurrentDb.OpenRecordset("tbl_TempLstFrm", dbOpenSnapshot)
' recherche les informations de la table
rst.FindFirst ("Table='" & Me.cbo_table & "'")
If rst.NoMatch Then ' non trouvé
MsgBox "Cette table ne possède pas de formulaire. Veuillez renseigner la table des paramètres.", _
vbCritical + vbOKOnly, "formulaire de Recherche"
Exit Sub
Else ' trouvé
If lf_GetTypeField(Me.cbo_table, rst.Fields("Champ")) = dbText Then 'la clef est Texte
strCriteria = rst.Fields("Champ") & "='" & Me.lst_resultat & "'"
Else 'la clef est numérique
strCriteria = rst.Fields("Champ") & "=" & Me.lst_resultat
End If
DoCmd.OpenForm rst.Fields("Formulaire"), acNormal, , strCriteria
End If
End Sub
Private Sub Btn_Click()
Dim rst As Recordset
Dim stDocName As String
Dim strWhere As String, strQry As String, p As Integer
On Error GoTo Err_Btn_Click
Set rst = CurrentDb.OpenRecordset("tbl_TempLstE", dbOpenSnapshot)
' recherche les informations de la table
rst.FindFirst ("Table='" & Me.cbo_table & "'")
If rst.NoMatch Then ' non trouvé
MsgBox "Cette table ne possède pas dEtat. Veuillez renseigner la table : tbl_TempLstE .", _
vbCritical + vbOKOnly, "formulaire de Recherche"
Exit Sub
End If
stDocName = rst.Fields("Etat")
' Extrait condition WHERE du source SQL
' de la liste résultat
strQry = Me.lst_resultat.RowSource
p = InStr(1, strQry, "WHERE ", vbTextCompare)
If p = 0 Then GoTo Exit_Btn_Click
strWhere = Mid(strQry, p + 6, Len(strQry) - p - 5)
strWhere = Trim(strWhere)
If Right(strWhere, 1) = ";" Then _
strWhere = Left(strWhere, Len(strWhere) - 1)
DoCmd.Minimize
DoCmd.OpenReport stDocName, acPreview, , strWhere
Exit_Btn_Click:
Exit Sub
Err_Btn_Click:
MsgBox Err.Description
Resume Exit_Btn_Click
Private Sub Commande40_Click()
On Error GoTo Err_Commande40_Click
DoCmd.GoToRecord , , acLast
Exit_Commande40_Click:
Exit Sub
Err_Commande40_Click:
MsgBox Err.Description
Resume Exit_Commande40_Click
End Sub
Private Sub Commande47_Click()
On Error GoTo Err_Commande47_Click
DoCmd.GoToRecord , , acLast
Exit_Commande47_Click:
Exit Sub
Err_Commande47_Click:
MsgBox Err.Description
Resume Exit_Commande47_Click
End Sub
Private Sub Opt_RechCourante_Click()
If Me.Opt_RechCourante = True Then ' recherche courante activée
Me.cbo_operateur.Visible = True
Me.lbl_operateur.Visible = True
Else
Me.cbo_operateur.Visible = False
Me.lbl_operateur.Visible = False
End If
End Sub |
Partager