SUIVIT DES ERREURS

'|---------------------------------------------------------------
'| module : basDebugPiste
'|---------------------------------------------------------------
'| Description : Fonctions de suivit d'erreurs
'|
'| Contenu :
'|---------------------------------------------------------------
'|  1>    Push(ByVal strNomProc As gudtSuivit)
'|
'|  Remplissage du tableau
'|     Cette SubRoutine doit etre appelee
'|     au début de chaques fonction ou Sub
'|
'|     on doit lui fournir un objet de type gudtSuivit
'|     comportant :
'|                   .NomModule
'|                   .NomFonction
'|---------------------------------------------------------------
'|  2> Pop()
'|
'|on vide le tableau
'|
'|     Doit etre présent en fin de fonction ou
'|     SubRoutine
'|----------------------------------------------------------------
'|  3> Public Sub AfficheErreur(ByVal NumErreur As String, _
'|                              ByVal DescriptionErreur As String, _
'|                              Optional ByVal FichierErreur As String)
'|
'|  affichage des informations concernant l'erreur
'|
'|    Valeurs a fournir :
'|           NumErreur             Le N° de l'erreur  (err.Number)
'|           DescriptionErreur     La description de l'erreur (err.description)
'|     Optionel :
'|           Un fichier d'erreur   A decrire depuis la racine (ex : "C:\lulu\Erreur.log" )
'|           Si le fichier n'existe pas -> Il est cree
'|           Le fichier est mis en lecture seule (pas de manips manuelles)
'|           Pas de test d'existence du répertoire -> le créer au préalable
'|                -> sinon pb (vrai aussi pour un disque <>)
'|---------------------------------------------------------------------
'| Utilisation :
'|
'|    ---------------------------------------------------
'|    Lors de ma mise en place d'un programme
'|    il faut initialiser la variable publique
'|    glngIndex a -1  (pour Form_load ou Sub main)
'|    ---------------------------------------------------
'|
'|    Private Sub Form_Load()
'|
'|         initialisation de la variable erreur
'|         Dim Erreur As gudtSuivit
'|         on met l'index du tableau a -1
'|         glngIndex = -1
'|    With Erreur
'|       .NomModule = "frmDebug"
'|       .NomFonction = "Form_Load"
'|    End With
'|
'|    on rempli le tableau
'|    Push Erreur
'|
'|    Si une erreur se produit :
'|    On Error GoTo etqErreur
'|
'|    Bla bla ..... le programme
'|    avoir   'une SubRoutine
'|    Bla bla.....
'|
'|    sortie de la subroutine
'|    etqSortie:
'|         Pop         'on vide le tableau d'un élément
'|    Exit Sub    'on sort
'|----
'|    etqErreur:  'les erreurs sont traitées Ici
'|         utilisation du suivit d'erreurs
'|         AfficheErreur Err.Number, Err.Description
'|    GoTo etqSortie  'on sort par etqSortie
'|
'|   End Sub ' fin de form_load
'|  ----------------------------------------------------------------
'|  pour une fonction ou SubRoutine Lamba.....
'|
'|     public sub (ou function) avoir()
'|
'|     Dim lulu as gudtSuivit
'|         with lulu
'|            .NomModule = "Nom du fichier intégrant avoir"
'|            .NomFonction = "avoir"
'|         End With
'|     Push lulu
'|
'|     on error goto etqErreur
'|
'|        Blabla.......................
'|
'|     etqSortie:
'|        pop
'|     exit sub  (ou exit function)
'|
'|     etqErreur:
'|        AfficheErreur Err.Number, Err.Description
'|        GoTo etqSortie  'on sort par etqSortie
'|
'|     end sub (ou end function)
'|---------------------------------------------------------------------
'| Eléments(s) utilisé(s) par ce module : Bib/Fichiers/F_Fich_Dir.bas
'|
'|---------------------------------------------------------------------
'| Versions :
'|
'|   jim   le : 25/09/2002   origine
'|
'|#--------------------------------------------------------------------

Option Explicit
 
'----------------------------------------------------------------
' Objet de suivit
'       NomModule   :  Nom du fichier ou se trouve la fonction
'                      ou la SubRoutine
'       NomFonction :  Nom de la fonction ou subroutine
'----------------------------------------------------------------
Public Type gudtSuivit

    NomModule         As String
    NomFonction       As String

End Type
'----------------------------------------------------------------
Public gpstrTabTrace()    As gudtSuivit  'Le tableau du suivit
Public glngIndex          As Long        'Index du tableau
'----------------------------------------------------------------

'----------------------------------------------------------------
'Remplissage du tableau
'     Cette SubRoutine doit etre appelee
'     au début de chaques fonction ou Sub
'
'     on doit lui fournir un objet de type gudtSuivit
'     comportant :
'                   .NomModule
'                   .NomFonction
'----------------------------------------------------------------

Public Sub Push(strNomProc As gudtSuivit)

     'On ajoute un case au tableau
     '-----------------------------------
     glngIndex = glngIndex + 1
     ReDim Preserve gpstrTabTrace(glngIndex)
  
     'On lui affecte le nom de la fonction ou la proc en cours
     '---------------------------------------------------------
     gpstrTabTrace(glngIndex) = strNomProc


End Sub

'---------------------------------------------------------------
'on vide le tableau
'
'     Doit etre présent en fin de fonction ou
'     SubRoutine
'----------------------------------------------------------------
Public Sub Pop()

        'on vide la derniere case du tableau
        'si on est pas sur la derniere case
        '--------------------------------------------
        If UBound(gpstrTabTrace) <> 0 Then
           ReDim Preserve gpstrTabTrace(UBound(gpstrTabTrace) - 1)
           glngIndex = glngIndex - 1
        Else
        'sinon on vide le fichier
           Erase gpstrTabTrace
           glngIndex = -1
        
        End If

End Sub


'----------------------------------------------------------------------------
'affichage des informations concernant l'erreur
'
'     Valeurs a fournir :
'           NumErreur             Le N° de l'erreur  (err.Number)
'           DescriptionErreur     La description de l'erreur (err.description)
'     Optionel :
'           Un fichier d'erreur   A decrire depuis la racine (ex : "C:\lulu\Erreur.log" )
'           Si le fichier n'existe pas -> Il est cree
'           Le fichier est mis en lecture seule (pas de manips manuelles)
'----------------------------------------------------------------------------

Public Sub AfficheErreur(ByVal NumErreur As String, _
                         ByVal DescriptionErreur As String, _
                         Optional ByVal FichierErreur As String)
'--------------------------------------------
Dim strMsgErreur        As String  'le message a afficher
Dim i                   As Long    'un compteur
Dim retour              As Boolean 'pour test d'existence du fichier d'erreurs
Dim xlog                As Long    'Num du fichier erreur

strMsgErreur = ""
xlog = FreeFile
'-------------------------------------------

  strMsgErreur = "--------------------------------------------" + vbCrLf _
               + "Erreur N° " & NumErreur + vbCrLf _
               + DescriptionErreur + vbCrLf _
               + "--------------------------------------------" + vbCrLf
  '--------------------------------------------------
  'affichage des différentes procédures actives
  'en partant de la derniere en cours
  '--------------------------------------------------
  For i = UBound(gpstrTabTrace) To 0 Step -1
    strMsgErreur = strMsgErreur & _
                   "Module : " & gpstrTabTrace(i).NomModule & " " & " <-> " & _
                   "Fonction : " & gpstrTabTrace(i).NomFonction & vbCrLf
  Next i

  'affichage de la boite de message
  '---------------------------------------
  MsgBox strMsgErreur
  
  '---------------------------------------
  'Fichier d'erreur
  '---------------------------------------
  'si le parametre existe
  If FichierErreur <> "" Then
    'on teste s'il existe déjà
    retour = Test_Fichier(FichierErreur)   '-> voir module F_Fich_Dir.bas
                                                          'integrer la fonction fso pour etre autonome
    
    If retour = False Then 'il n'existe pas
      Open FichierErreur For Output As xlog
      Print #xlog, "--------------------------------------------"
      Print #xlog, "    Le  : " & Date & " a " & Time
      Print #xlog, strMsgErreur
      Close #xlog
      SetAttr FichierErreur, vbReadOnly
    Else  'il existe
          'Append
      SetAttr FichierErreur, vbNormal
      Open FichierErreur For Append As xlog
      Print #xlog, "--------------------------------------------"
      Print #xlog, "    Le  : " & Date & " a  " & Time
      Print #xlog, strMsgErreur
      Close #xlog
      SetAttr FichierErreur, vbReadOnly
    End If
  End If
                        
End Sub

Télécharger le zip