Lenteur d'exécution aléatoire de VBA avec Access

**FRinguette** · 08/11/2017, 17h27

J'utilise une application Access 2013 pour accéder à une base de donnée dans SQL Server express 2012.

Dans plusieurs procédures, j'exécute en mode transactionnel une commande ADODB dans une boucle While- Wend pour chaque enregistrement trouvé et stoqué dans un recordset et tout fonctionne normalement. Or, pour une de ces procédures, l'exécution du code VBA devient très lent au point qu' il y a génération de l'erreur :

"ODBC -- l'appel a échoué.

[Microsoft][SQL Server Native Client 11.0]Query timeout expired (#0) "

Ce qui m'intrigue, c'est que parfois l'exécution du code fonctionne normalement et que plus souvent qu'autrement, il ralentit, principalement lors de la première exécution de l'objet ADODB.Command.

Je soupçonne que c'est le ralentissement d'exécution qui empêche la connexion à la BD mais je ne sais comment identifier la cause de ce ralentissement et encore moins comment le régler. Merci d'avance pour l'aide!!

Voici le code problématique :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub MAJHDepTrav(strNomForm As String, numIdFTemps As Long)
    On Error GoTo Trappe
 
    Dim cn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim rs As ADODB.Recordset
    Dim strSQL As String
    Dim numIdEmpl, numHTotEmpl, curDepTotEmpl
    Dim numIdProjet As Long
    Dim strSource As String
 
    strSource = "modProjets.MAJHDepTrav"
    LogEvt strSource, strSource, TYPE_EVT_INFO
 
    Set cn = CurrentProject.Connection
    cn.BeginTrans
 
   numIdEmpl = CLng(DLookup("[FK_Empl]", "tblFTemps", "Id = " & numIdFTemps))
 
   'Récup dela liste des projets de la feuille de temps à mettre à jour
    Select Case strNomForm
 
        Case "frmFTemps"
            strSQL = "SELECT distinct tblFTempsLignes.FK_Projet" & _
                    " FROM  tblFTempsLignes LEFT JOIN tblProjets ON tblFTempsLignes.FK_Projet = tblProjets.ID" & _
                    " WHERE tblFTempsLignes.FK_FTemps = " & numIdFTemps & " AND tblProjets.FK_Statut=9" & _
                            " Or tblFTempsLignes.FK_FTemps = " & numIdFTemps & " AND tblProjets.FK_Statut=65"
        Case Else
            strSQL = "SELECT [ID] FROM tblProjets WHERE FK_Statut = 9 or FK_Statut = 65"
    End Select
 
    Set rs = New ADODB.Recordset
    rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly
 
    'Mise-à-jour de [tblAFacturer]![HTotTrav] et [tblAFacturer]![DepTotTrav] ou ajout d'un enregistrement dans tblAFacturer pour les projets sélectionnés.
    While Not rs.BOF And Not rs.EOF
 
        'Récup des données à transférer
        Select Case strNomForm
            Case "frmFTemps"
                numIdProjet = rs.Fields![FK_Projet].Value
            Case Else
                numIdProjet = rs.Fields![Id].Value
        End Select
 
        numHTotEmpl = DLookup("[HTrav]", "qryTotTrav", "FK_Projet = " & numIdProjet & " and FK_Empl = " & numIdEmpl)
        curDepTotEmpl = DLookup("[DepTrav]", "qryTotTrav", "FK_Projet = " & numIdProjet & " and FK_Empl = " & numIdEmpl)
 
        'MAJ ou ajout dans tblAFacturer selon qu'il s'agit ou non d'un nouvel employé à facturer
        If NouvelEmplAFacturer(ByVal numIdEmpl, ByVal numIdProjet) Then
 
            Set cmd = New ADODB.Command
            With cmd
                .ActiveConnection = cn
                .CommandType = adCmdText
                strSQL = ""
                strSQL = strSQL & "INSERT INTO tblAFacturer"
                strSQL = strSQL & " (FK_Projet, FK_Empl, HTotTrav, DepTotTrav, HTotFact, DepTotFact)"
                strSQL = strSQL & " VALUES(" & numIdProjet & ", " _
                                             & numIdEmpl & ", " _
                                             & Replace(numHTotEmpl, ",", ".") & ", " _
                                             & Replace(curDepTotEmpl, ",", ".") & ", 0, 0)"
                .CommandText = strSQL
                .Execute
            End With
        Else
            Set cmd = New ADODB.Command
            With cmd
                .ActiveConnection = cn
                .CommandType = adCmdText
                strSQL = ""
                strSQL = strSQL & "UPDATE tblAFacturer"
                strSQL = strSQL & " SET [HTotTrav] = " & Replace(numHTotEmpl, ",", ".")
                strSQL = strSQL & ", [DepTotTrav] = " & Replace(curDepTotEmpl, ",", ".")
                strSQL = strSQL & " WHERE FK_Projet = " & numIdProjet & " and FK_Empl = " & numIdEmpl
                .CommandText = strSQL
                .Execute
            End With
        End If
        rs.MoveNext
    Wend
 
    'On sauvegarde TOUTES les modifications
    cn.CommitTrans
 
Sortie:
    'Ménage
    On Error Resume Next
    pnumErrNum = 0
    pstrErrDescr = ""
    rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
Trappe:
    pnumErrNum = Err.Number
    pstrErrDescr = Err.Description
    LogErr pnumErrNum & ": " & pstrErrDescr, strSource
    Select Case pnumErrNum
 
        Case Else
            On Error Resume Next
            pnumErrNum = 0
            pstrErrDescr = ""
            Err.Clear
            cn.RollbackTrans
            If Err.Number <> 0 Then LogErr ERR1093_DESCR, strSource
            rs.Close
            Set rs = Nothing
            Set cmd = Nothing
            cn.Close
            Set cn = Nothing
            Err.Raise ERR1160, strSource, ERR1160_DESCR
    End Select
End Sub 'MAJHDepTrav

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Function NouvelEmplAFacturer(ByVal numIdEmpl As Long, ByVal numIdProjet As Long) As Boolean
    On Error GoTo Trappe
    'Vérifie si on doit ajouter une ligne à tblAFacturer qui correspond à la ligne de tblFTempsLignes
    'Ex: MsgBox NouvelEmplAFacturer(4, 1255)
 
    Dim numResult As Integer
    Dim strSource As String
 
    strSource = "modProjets.NouvelEmplAFacturer"
    LogEvt strSource, strSource, TYPE_EVT_INFO
 
    numResult = DCount("[Id]", "tblAFacturer", "FK_Projet = " & numIdProjet & " and FK_Empl = " & numIdEmpl)
 
    If numResult = 0 Then
        NouvelEmplAFacturer = True
    Else
        NouvelEmplAFacturer = False
    End If
Sortie:
    On Error Resume Next
    pnumErrNum = 0
    pstrErrDescr = ""
    Exit Function
Trappe:
    pnumErrNum = Err.Number
    pstrErrDescr = Err.Description
    LogErr pnumErrNum & ": " & pstrErrDescr, strSource
    Select Case pnumErrNum
 
        Case Else
            Err.Raise ERR1159, strSource, ERR1159_DESCR
    End Select
    Resume Sortie
End Function 'NouvelEmplAFacturer

**Zekraoui_Jakani** · 09/11/2017, 21h08

Je n'ai pas le temps de lire le code mnt; mais avez-vous essayer de compacter la db de temps en temps ?

**FRinguette** · 09/11/2017, 22h55

Je compacte la db régulièrement.

De mon côté, j'ai créé une fonction scalaire dans la db sur SQL Server pour remplacer la requête qryTotTrav qui semble ralentir le code.

Je pense être sur la bonne voie mais je continue à faire des tests.

Merci!

**FRinguette** · 10/11/2017, 11h30

Se pourrait-il qu'en mode transactionnel, il y ait une limite du nombre de modifications que la mémoire peut emmagasiner avant un CommitTrans ou encore un nombre limite d'itérations de la boucle While-Wend (178 dans mon cas) ? Après des tests, je remarque que le code plante toujours au traitement du même enregistrement (174 sur 178).

De plus, lorsque j'utilise le code avec un nombre plus restreint d'enregistrements à traiter, cela fonctionne.

Merci d'avance!

**Zekraoui_Jakani** · 10/11/2017, 19h21

Je suppose qu'il n'y a pas de problème de saturation de mémoire!
Le code me paraît correct; mes suggestions: le "commit trans" est inutile dans ce cas précis, et ça prend de la mémoire pour rien.
Autre amélioration possible (à tester le temps de voir si ça tourne mieux): remplacer l'UPDATE par une simple query de mise à jour à appeler dans le code; ça peut jouer, mais pour l'instant je n'ai pas de meilleure pistes que celles énumérées ci-dessus.

**FRinguette** · 21/11/2017, 15h35

Après réflexion, je suis réticent à enlever le CommitTrans/RollbackTrans de ma procédure justement au cas où la boucle plante, je veux éviter que les données soient modifiées partiellement.

Je vais plutôt essayer de contourner le problème en utilisant le code seulement avec le formulaire qui commande l'exécution sur un nombre plus restreint d'enregistrements. Je vous reviendrai pour vous dire si tout fonctionne.

Merci!

Lenteur d'exécution aléatoire de VBA avec Access

VBA Access

Discussions similaires

Partager

Partager