VBA - Forcer la fermeture d'1 boite de dialogue système d'erreur

**informer** · 30/11/2012, 12h21

Bonjour à tous

Contexte
Je charge chaque fichier XLSX d’un répertoire dans la table associée. L’association du nom d'une table avec le nom d’un fichier est faite dans une table tImportFichierXls avec les champs (table,fihcierXls,statut).
Pour charger les fichiers Excel dans leur table respective, je fais une boucle de lecture de tous les fichiers Excel du répertoire source indiqué par une variable sPath et je charge chaque fichier via DoCmd.TransferSpreadsheet acImport, 8, recSet!Table, sPath & sFileXls, True
A chaque opération de chargement je mets à jour dans la table tImportFichierXls le statut associé au fichier Excel chargé avec Ok ou Echec

Problème
Si DoCmd.TransferSpreadsheet provoque une erreur, ici dû à une violation d’intégrité d’une table, il y a un message système d’erreur qui demande à être validé manuellement.
Si j’utilise DoCmd.setwarnings, cela désactive l’affichage mais aussi la gestion des erreurs. Or j’ai besoin de donner un statut leOk ou échec à chaque chargement de fichier dans la table tImportFichierXls. Cela est possible que si je trappe l’erreur mais je ne veux pas de validation manuelle de la boite de dialogue système d’erreur qui apparait. Et de plus l’erreur est activée que si clique sur le bouton non indiquant mon refus de charger la table

Quelqu’un a la solution ?

J’ai essayé sendkeys mais solution à oublier car doit être mise avant DoCmd.TransferSpreadsheet. Or ne doit être lancée que si DoCmd.TransferSpreadsheet génère une erreur et non à chaque chargement. Il le fait donc à chaque chargement or chaque chargement ne génère pas d’erreur !!!!

Merci pour votre aide

Mon code

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
Private Sub cmdImportData_Click()
 
On Error GoTo Err_<div style="margin-left:40px">Dim sPath As String, sFileXls As String, sSQL As String, sMsg As String, sErrDesc As String, sErrNbr As String
Dim bError As Boolean
Dim i As Long
'Définit le répertoire contenant les fichiers
sPath = Me.txtChemin
 
'Boucle sur tous les fichiers xls du répertoire.
sFileXls = Dir(sPath & "*.xlsx")
Do While Len(sFileXls) > 0<div style="margin-left:40px">bError = False
 
sSQL = "SELECT * FROM tImportFichierXls WHERE ficherExcel= '" & sFileXls & "'"
Set recSet = CurrentDb.OpenRecordset(sSQL)
If Not recSet.EOF Then<div style="margin-left:40px">sSQL = "DELETE * FROM " & recSet!Table
CurrentDb.Execute (sSQL)
 
 
DoCmd.TransferSpreadsheet acImport, 8, recSet!Table, sPath & sFileXls, True
 
recSet.Edit
 recSet!DateLastMaj = Now()
 If bError = False Then<div style="margin-left:40px">recSet!Statut = "Ok"
recSet!info = ""</div>Else<div style="margin-left:40px">recSet!Statut = "Echec"
recSet!info = sErrDesc & " - Code :" & sErrNbr</div>End If
recSet.Update
recSet.Close</div>End If
<div style="margin-left:40px">sFile</div></div>Xls = Dir() 'Récpére le fichier Excel suivant
Loop
 
 
sSQL = "SELECT * FROM tImportFichierXls WHERE statut = 'Echec'"
Set recSet = CurrentDb.OpenRecordset(sSQL)
If Not recSet.EOF Then<div style="margin-left:40px">sMsg = "Fin du traitement d'importation" & Chr(13) & "Erreur(s) de chargement ! Voir l'état du statut des importations"
MsgBox sMsg, vbCritical</div>Else<div style="margin-left:40px">sMsg = "Fin du traitement d'importation réussi"
MsgBox sMsg, vbInformation</div>End If
recSet.Close</div>Exit_Err_:<div style="margin-left:40px">Exit Sub</div>Err_:<div style="margin-left:40px">bError = True
sErrDesc = Err.Description
sErrNbr = Err.Number
Resume Next</div>End Sub

**Jeremou** · 30/11/2012, 18h54

Bonjour Informer,

Veux-tu détecter toutes les erreurs d'importation ou seulement les violations de clé ?

Si tu es dans le 2ème cas, l'import d'une table temporaire te permettra de comparer le nombre d'enregistrements. (cf code ci-dessous)
Si tu es dans le 1er cas, après une courte recherche, il semble que Access ne permette pas de trapper ce genre d'erreurs...(à moins que je ne me trompe)

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
 
On Error GoTo Err_
Dim sPath As String, sFileXls As String, sSQL As String, sMsg As String, sErrDesc As String, sErrNbr As String
Dim bError As Boolean
Dim i As Long
'Définit le répertoire contenant les fichiers
sPath = Me.txtChemin
 
DoCmd.SetWarnings False
 
'Boucle sur tous les fichiers xls du répertoire.
sFileXls = Dir(sPath & "*.xlsx")
Do While Len(sFileXls) > 0
bError = False
 
sSQL = "SELECT * FROM tImportFichierXls WHERE ficherExcel= '" & sFileXls & "'"
Set recSet = CurrentDb.OpenRecordset(sSQL)
If Not recSet.EOF Then
    sSQL = "DELETE * FROM " & recSet!Table
    CurrentDb.Execute (sSQL)
 
    If ExisteTable(recSet!Table & "_Temp") Then DoCmd.DeleteObject acTable, (recSet!Table & "_Temp")
    DoCmd.TransferSpreadsheet acImport, 8, recSet!Table & "_Temp", sPath & sFileXls, True
    DoCmd.TransferSpreadsheet acImport, 8, recSet!Table, sPath & sFileXls, True
 
 
    recSet.Edit
    recSet!DateLastMaj = Now()
    If CurrentDb.TableDefs(recSet!Table).RecordCount = CurrentDb.TableDefs(recSet!Table & "_Temp").RecordCount Then
        recSet!Statut = "Ok"
        recSet!info = ""
    Else
        recSet!Statut = "Echec"
        recSet!info = "Violation de clé"
    End If
    recSet.Update
 
    If ExisteTable(recSet!Table & "_Temp") Then DoCmd.DeleteObject acTable, (recSet!Table & "_Temp")
 
    recSet.Close
End If
 
sFileXls = Dir() 'Récpére le fichier Excel suivant
Loop
 
 
sSQL = "SELECT * FROM tImportFichierXls WHERE statut = 'Echec'"
Set recSet = CurrentDb.OpenRecordset(sSQL)
If Not recSet.EOF Then
sMsg = "Fin du traitement d'importation" & Chr(13) & "Erreur(s) de chargement ! Voir l'état du statut des importations"
MsgBox sMsg, vbCritical
Else
sMsg = "Fin du traitement d'importation réussi"
MsgBox sMsg, vbInformation
End If
recSet.Close
Exit_Err_:
DoCmd.SetWarnings True
Exit Sub
 
Err_:
bError = True
sErrDesc = Err.Description
sErrNbr = Err.Number
Resume Next
 
 
 
'////////////////////////////////////////////////////////
'Fonction permet de tester si une table existe
Function ExisteTable(ByVal strTabl As String) As Boolean
    Dim str As String
    On Error GoTo err01
    str = CurrentDb.TableDefs(strTabl).Name
    ExisteTable = True
    Exit Function
err01:
    Select Case Err.Number
        Case 3265
            ExisteTable = False
    End Select
 
End Function

**informer** · 06/12/2012, 13h42

Bonjour Jeremou,

Merci pour ta réponse et effectivement ma question portait sur le fait de capturer toutes erreurs et pas seulement sur la violation de clé .. Donc je me trouve bien en peine quoi !!! Mais encore fois merci Jeremou.

J'en profite pour continuer la discussion sur le gestionnaire système d'erreur (je sais pas comment le nommer autrement).

J'ai voulu utiliser BeginTrans, Rollback et CommitTrans, qui se fait avec un workspace déclaré avec la procédure ci-dessous

Code :

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

1
2
 Set wrkCurrent = DBEngine.Workspaces(0) 
wrkCurrent.BeginTrans

Problème
Pour travailler sur les tables du workspace, je dois utiliser CurrentDb.Execute (sRequete) mais CurrentDb ne lance pas le gestionnaire système d'erreur (A confirmer???).

Et si j'utilise Docmd.RunSQL, qui lui lance le gestionnaire, sur les tables du workspace, j'ai un message indiquant que la ou les tables du workSpace sont en lecture exclusives et ne peuvent être modifiées par la commande DoCmd.RunSQL (normal après réflexion)

Mais est il possible d'utiliser le Workspace + DoCmd.RunSQL, par une astuce?

Merci pour ton retour

**nico84** · 07/12/2012, 15h37

Bonjour,

Envoyé par informer

mais CurrentDb ne lance pas le gestionnaire système d'erreur (A confirmer???).

Si si

Code :

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

1
2
3
4
5
6
7
8
On Error GoTo err:
...
110     Sr = "UPDATE ...;"
112     CurrentDb.Execute Sr, dbFailOnError
...
    Exit Sub
err: msgbox("Erreur " & err.Number & "/" & Erl & " dans " & TypeName(Me) & " : " & err.description
End Sub

**informer** · 10/12/2012, 01h27

Salut nico84

Merci pour ton aide précieuse.

Pour qui cela pourrait aider ou qui voudrait optimiser le code

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
118
 
Private Sub cmdImportData_Click()
 
On Error GoTo Err_
 
    Dim sPath As String, sFileXls As String, sSQL As String, sMsg As String, sErrDesc As String, sFileType As String
    Dim sTable As String, sInfo As String, sStatut As String
    Dim bError As Boolean
    Dim i As Long, lNbrRecord As Long, lErrNbr As Long
    Dim dMaj As Date
 
   'Définit le répertoire contenant les fichiers
    sPath = Me.txtChemin 'Récupéré depuis le formulaire
 
    sFileType = "xlsx"
 
    'Boucle sur tous les fichiers xls du répertoire.
    sFileXls = Dir(sPath & "*." & sFileType)
 
    'Options de traitement des erreurs
    DoCmd.SetWarnings True
    Application.SetOption "Confirm Action Queries", False
 
    Do While Len(sFileXls) > 0
        bError = False
 
        Set wrkCurrent = DBEngine.Workspaces(0)
        wrkCurrent.BeginTrans
 
        sSQL = "SELECT * FROM tImportFichierXls WHERE ficherExcel= '" & sFileXls & "'"
        Set recSet = CurrentDb.OpenRecordset(sSQL)
 
        If Not recSet.EOF Then
 
            sTable = recSet!Table
 
            'Supprime tous les enrgistrements de la table master
            sSQL = "DELETE * FROM " & recSet!Table
            CurrentDb.Execute sSQL, dbFailOnError
 
            DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel8, sTable & sFileType, sPath & sFileXls, True
 
 
            sSQL = "INSERT INTO " & recSet!Table & " SELECT * FROM " & sTable & sFileType
            CurrentDb.Execute sSQL, dbFailOnError
 
 
            If bError = False Then 'Si pas d'erreur de chargement
                wrkCurrent.CommitTrans
            Else 'Si erreur de chargement
                 wrkCurrent.Rollback
            End If
 
            wrkCurrent.Close
            Set wrkCurrent = Nothing
 
 
            sSQL = "DROP TABLE " & sTable & sFileType
            CurrentDb.Execute sSQL, dbFailOnError
 
            sSQL = "SELECT * FROM tImportFichierXls WHERE table= '" & sTable & "'"
            Set recSet = CurrentDb.OpenRecordset(sSQL)
 
            If Not recSet.EOF Then
 
                recSet.Edit
                recSet!DateLastMaj = Now()
 
                If bError = False Then 'Si pas d'erreur de chargement
                    recSet!Statut = "Ok"
                    recSet!info = ""
                Else 'Si erreur de chargement
                    recSet!Statut = "Echec"
                    recSet!info = sErrDesc
                End If
 
                recSet.Update
            End If
 
 
            recSet.Close
            Set recSet = Nothing
 
        End If
 
        sFileXls = Dir() 'Récpére le fichier Excel suivant
 
    Loop
 
    sSQL = "SELECT * FROM tImportFichierXls WHERE statut = 'Echec'"
    Set recSet = CurrentDb.OpenRecordset(sSQL)
    If Not recSet.EOF Then
        sMsg = "Fin du traitement d'importation" & Chr(13) & "Erreur(s) de chargement! Voir l'état du statut des importations"
        MsgBox sMsg, vbCritical
    Else
        sMsg = "Fin du traitement d'importation" & Chr(13) & "Opération réussie"
        MsgBox sMsg, vbExclamation
    End If
 
    recSet.Close
    Set recSet = Nothing
 
 
Exit_Err_:
 
    Exit Sub
 
Err_:
        bError = True
       sErrDesc = sTable & " n'a pas été mise à jour. " & Err.Description & " " & Err.Number
     lErrNbr = Err.Number
 
     MsgBox sErrDesc, vbCritical
 
 
    Resume Next
 
End Sub

VBA - Forcer la fermeture d'1 boite de dialogue système d'erreur [AC-2010]

VBA Access

Discussions similaires

Partager

Partager