Traitement d'erreur

Signaler
Messages postés
4
Date d'inscription
mardi 16 novembre 2004
Statut
Membre
Dernière intervention
26 janvier 2005
-
Messages postés
4
Date d'inscription
mardi 16 novembre 2004
Statut
Membre
Dernière intervention
26 janvier 2005
-
Bonjour,
Est ce que kk1 pourrait m'éclairer sur un problème de boucle. En fait, dans le programme, on a affaire à un traitement d'erreur de fichiers .eml. Le programme parcours des répertoires récupère des codes lot et opération et affiche le résultat dans un fichier .txt. S'il ya des erreurs il les détecte et affiche le tout ds un fichier error.log.
Moi je voudrais avoir le nombre d'erreurs correspondant à chaque opération dans chaque répertoire; et je n'arrive pas à faire une bonne boucle.
Merci de me répondre.

Annick

2 réponses

Messages postés
14008
Date d'inscription
samedi 29 décembre 2001
Statut
Modérateur
Dernière intervention
28 août 2015
81
Question pas assez précise.
Quand tu parles d'erreur, ce sont des erreurs de quoi ? du programme ? --> Voir "On Error Goto monLabel" dans l'aide de VB6

Vala
Jack
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage. (Socrate)
Messages postés
4
Date d'inscription
mardi 16 novembre 2004
Statut
Membre
Dernière intervention
26 janvier 2005

Merci de me répondre Jack. Je vais essayer d'ête plus claire.
En fait c'est un programme qui doit nettoyer une base de donnée client et qui fonctionne en mode console(il faut entre autre l'automatiser, c'est aussi un autre pb et je souhaiterais savoir comment?). Pour des retours de mails, il doit savoir la cause du retour.
Mais mon petit problème c'est que je veux qu'il affiche le nombre total d'erreur survenue pour chaque opération (sClientOp). Les sous dossiers correspondants aux clients contiennent des fichiers .msg, lesquels comprennent les numéros d'opérations. Mais ces fichiers .msg ne sont parfois pas en ordre ds le dossier client.
Je veux que pour une opération 8 du client X, il affiche:
Client:X
Op:8
Nbre erreur:12
*************
Op:10
Nbre erreur:5
***************
Op:15
Nbre erreur:20
**************
**************
Client:Y
Op:5
Nbre erreur:10
*************
Op:7
Nbre erreur:15
****************
etc..........

En fait voici ce que fait le programme:
Option Explicit
Option Base 0


Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, dwMode As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long


Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&


Private Const ENABLE_ECHO_INPUT = &H4


Private Type COORD
x As Integer
y As Integer
End Type


Private Type SMALL_RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type


Private Type CONSOLE_SCREEN_BUFFER_INFO
dwSize As COORD
dwCursorPosition As COORD
wAttributes As Integer
srWindow As SMALL_RECT
dwMaximumWindowSize As COORD
End Type


Private Declare Function GetConsoleScreenBufferInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO) As Long


Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long


Private Const FOREGROUND_BLUE = &H1 ' text color contains blue.
Private Const FOREGROUND_GREEN = &H2 ' text color contains green.
Private Const FOREGROUND_INTENSITY = &H8 ' text color is intensified.
Private Const FOREGROUND_RED = &H4 ' text color contains red.


Private hOutput As Long
Private hInput As Long


Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFFFFFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long



' Application declarations
Private Const EM_LICENSE = "Louise Priest (Single Developer)/0010630410721500AB30"


Dim oCnBounce As ADODB.Connection, oRsBounce As ADODB.Recordset
Dim oFSO As Scripting.FileSystemObject


Sub Main()
Dim scrbuf As CONSOLE_SCREEN_BUFFER_INFO

hInput = GetStdHandle(STD_INPUT_HANDLE)
If SetConsoleMode(hInput, ENABLE_ECHO_INPUT) <> 0 Then Err.Raise -1, "ip3bounce", "No input console"
hOutput = GetStdHandle(STD_OUTPUT_HANDLE)


GetConsoleScreenBufferInfo hOutput, scrbuf


Dim sCommand As String
sCommand = Command()
If sCommand "-?" Or sCommand "/?" Or sCommand = "/help" Or sCommand = "-help" Then
WriteToConsole "IP3BOUNCE [-s chemin] [-d nom_de_fichier] [-y]" & vbNewLine & vbNewLine
WriteToConsole " -s Chemin vers les fichiers sources." & vbNewLine
WriteToConsole " -d Nom du fichier d'export." & vbNewLine
WriteToConsole " -m Chemin ou deplacer les fichiers en traitement." & vbNewLine
WriteToConsole " -yd Supprime les fichiers sources en traitement." & vbNewLine
WriteToConsole " -ym Deplace les fichiers sources en traitement." & vbNewLine
WriteToConsole " -i Mode interatif." & vbNewLine
WriteToConsole " -l Taille maximum par fichier a traiter." & vbNewLine

End
Else
WriteToConsole vbNewLine & "I-Pousse 3.0 Bounce Agent FS [version 3.0.0000]" & vbNewLine
WriteToConsole "(C) Copyright 2004 Agence I-Puzzle." & vbNewLine

WriteToConsole vbNewLine
WriteToConsole vbNewLine
End If

Dim sSourceFolder As String, sDestinationFile As String, sNomFichier As String, sDateGeneration As String, sMoveFolder As String, tMoveFolder As String, hMoveFolder As String, lMaxFileSize As Long
Dim bMoveFiles As Boolean, bDeleteFiles As Boolean, bInteractiveMode As Boolean

sSourceFolder = ""
sDestinationFile = ""
sMoveFolder = ""
lMaxFileSize = 131072
bDeleteFiles = False
bInteractiveMode = False


Dim oCommandCol As Collection

Dim oArgvParser As New ArgvParser
With oArgvParser
Set oCommandCol = .CommandToStringArray(sCommand)
Dim lArgIndex As Long
For lArgIndex = 1 To oCommandCol.Count
If oCommandCol(lArgIndex) = "-s" And lArgIndex < oCommandCol.Count Then
sSourceFolder = oCommandCol(lArgIndex + 1)
WriteToConsole "Source folder is [" & sSourceFolder & "]" & vbNewLine
End If
If oCommandCol(lArgIndex) = "-m" And lArgIndex < oCommandCol.Count Then
sMoveFolder = oCommandCol(lArgIndex + 1)
WriteToConsole "Move folder is [" & sMoveFolder & "]" & vbNewLine
End If
If oCommandCol(lArgIndex) = "-d" And lArgIndex < oCommandCol.Count Then
sDestinationFile = oCommandCol(lArgIndex + 1)
WriteToConsole "Destination file is [" & sDestinationFile & "]" & vbNewLine
End If
If oCommandCol(lArgIndex) = "-l" And lArgIndex < oCommandCol.Count Then
lMaxFileSize = CLng(oCommandCol(lArgIndex + 1)) * 1024
WriteToConsole "Max file size to process is [" & lMaxFileSize & "]" & vbNewLine
End If
If oCommandCol(lArgIndex) = "-yd" Then
bDeleteFiles = True
End If
If oCommandCol(lArgIndex) = "-ym" Then
bMoveFiles = True
End If
If oCommandCol(lArgIndex) = "-i" Then
bInteractiveMode = True
End If
Next
End With
Set oArgvParser = Nothing


Call BounceSignature_Load


Set oFSO = New Scripting.FileSystemObject

Dim oFolder As Folder, oOpFolder As Folder, oClFolder As Folder, sFolder As Folder, oFile As File, oTextStream As TextStream, oDestinationStream As TextStream
Dim oLogStream As TextStream, oErrorStream As TextStream, oUnknownStream As TextStream, oUnknowntStream As TextStream
Dim sExtension As String, sbody As String, sBounceType As String, sBounceMessage As String, aTemp As Variant


Dim sClientId As String
Dim sClientOp As String
If sSourceFolder "" Then sSourceFolder CurDir 'If sDestinationFile "" Then sDestinationFile "I_POUSSE_BOUNCE_FS_" & Format(Now(), "YYYYMMDDHHNNSS" & ".txt") If sDestinationFile "" Then sDestinationFile "[" & sClientId & "_" & sClientOp & "_" & Format(Now(), "YYYYMMDDHHNNSS" & ".txt") & "]" If sNomFichier "" Then sNomFichier "[ Nom Fichier :" & sDestinationFile & "]" & vbNewLine If sDateGeneration "" Then sDateGeneration "[ Date génération :" & Format(Now(), "YYYY_MM_DD HH:NN:SS") & "]" & vbNewLine
If sMoveFolder <> "" Then
If oFSO.FolderExists(sMoveFolder) = False Then oFSO.CreateFolder sMoveFolder
End If

If oFSO.FolderExists(sSourceFolder) = True Then
Set oFolder = oFSO.GetFolder(sSourceFolder)
Set oDestinationStream = oFSO.CreateTextFile(sDestinationFile, False)
oDestinationStream.WriteLine ("Client" & vbTab & vbTab & "ClientOp" & vbTab & vbTab & "lot" & vbTab & vbTab & "Erreur" & vbTab & vbTab & "Type_Erreur") & vbNewLine
If oFSO.FileExists(App.Path & "\ip3bounce.log") = True Then
Set oLogStream = oFSO.GetFile(App.Path & "\ip3bounce.log").OpenAsTextStream(ForAppending)
Else
Set oLogStream = oFSO.CreateTextFile(App.Path & "\ip3bounce.log", False)
End If
If oFSO.FileExists(App.Path & "\ip3bounce.error.log") = True Then
Set oErrorStream = oFSO.GetFile(App.Path & "\ip3bounce.error.log").OpenAsTextStream(ForAppending)
Else
Set oErrorStream = oFSO.CreateTextFile(App.Path & "\ip3bounce.error.log", False)
End If
If oFSO.FileExists(App.Path & "\ip3bounce.unknown.log") = True Then
Set oUnknownStream = oFSO.GetFile(App.Path & "\ip3bounce.unknown.log").OpenAsTextStream(ForAppending)
Else
Set oUnknownStream = oFSO.CreateTextFile(App.Path & "\ip3bounce.unknown.log", False)
End If

oLogStream.Write vbNewLine & vbNewLine
oLogStream.WriteLine App.ProductName & " [" & App.Major & "." & Format(App.Minor, "0") & "." & Format(App.Revision, "0000") & "]"
oLogStream.WriteLine Now() & " - Processing start for source folder [" & sSourceFolder & "] to destination file [" & sDestinationFile & "]"


'rajouter dim tFilesMoved, lClientOp
Dim lFilesCount As Long, lFilesDeleted As Long, lMax As Long, lOpCount As Long, lFilesMoved As Long, tFilesMoved As Long, hFilesMoved As Long, lErrorsCount As Long, lFilesProcessed As Long
lFilesCount = 0
lMax = 0
lFilesDeleted = 0
lFilesMoved = 0
tFilesMoved = 0
lErrorsCount = 0
lFilesProcessed = 0
lOpCount = 0


Dim aTempOp As Variant
Dim aTempCl As Variant
Dim sOp As String
Dim c As Variant
Dim o As Variant
Dim i As Variant
Dim j As Variant

'If oFSO.FolderExists(oFolder.SubFolders) = False Then
'WriteToConsole vbNewLine & "pas de sous répertoire" & vbNewLine
'Else
On Error GoTo f
For Each sFolder In oFolder.SubFolders
oDestinationStream.WriteLine "Client :" & sFolder.Name
Exit Sub
f:
On Error Resume Next
'pour chaque fichier inclu dans ce sous répertoire
'For Each oFile In oFolder.Files

For Each oFile In sFolder.Files
sExtension = UCase(Right(oFile.Name, 4)) If (sExtension ".MSG" Or sExtension ".EML") Then
lFilesCount = lFilesCount + 1
If CLng(oFile.Size) > lMaxFileSize Then
WriteToConsole "Passed file due to maximum size limit [" & oFile.Name & "]."
lMax = lMax + 1
Else
Set oTextStream = oFile.OpenAsTextStream(ForReading)
sbody = oTextStream.ReadAll
sClientId = ""
sBounceType = BounceSignature_Identify(sbody)
oTextStream.Close
Set oTextStream = Nothing
sClientOp = ""
sClientId = XHeader_Identify(sbody, "X-Id_Client:")
sClientOp = XHeader_Identify(sbody, "X-Id_Campagne:")
'Ecrire dans le fichier destination, rajouter sClientOp(Id_Op) 'If sDestinationFile "" Then sDestinationFile "[" & sClientId & "_" & sClientOp & "_" & Format(Now(), "YYYYMMDDHHNNSS") & "_" & lFilesCount & "]" & ".txt"

'StrComp(i, j, vbTextCompare) = 1

'Créer un dossier de toutes les opérations et Id clients
Set oOpFolder = oFSO.GetFolder(sClientOp)
Set oClFolder = oFSO.GetFolder(sClientId)

aTempOp = Split(oOpFolder, "vbTab")
aTempCl = Split(oClFolder, "vbTab")
'c = aTempCl(0)
'o = aTempCl(c + 1)
i = aTempOp(0)
j = aTempOp(i + 1)

If sBounceType <> "0" Then
lFilesProcessed = lFilesProcessed + 1
aTemp = Split(sBounceType, ";")
sBounceMessage = Mid(sBounceType, Len(aTemp(0)) + 2)
sBounceType = aTemp(0)


If sClientId <> "" Then
WriteToConsole "Processed file [" & oFile.Name & "] as bounce [" & sBounceType & ";" & sBounceMessage & "]."

oDestinationStream.WriteLine (sClientId & vbTab & sClientOp & vbTab & XHeader_Identify(sbody, "X-Id_Lot:") & vbTab & sBounceMessage & vbTab & sBounceType) & vbNewLine
'Else
' oDestinationStream.WriteLine "Client = [" & Mid(sSourceFolder, 4) & "]_(" & c & ")" & vbNewLine
' oDestinationStream.WriteLine "Opération_Id = [" & i & "]" & vbNewLine
'End If

Else
WriteToConsole "Passed file due to unknown extended header [" & oFile.Name & "] but as bounce [" & sBounceType & ";" & sBounceMessage & "]."
oUnknownStream.WriteLine sDestinationFile & vbTab & oFile.Path & vbTab & "unknown_header"
oDestinationStream.WriteLine "unknown_Id" & vbTab & "unknown_Op" & vbTab & XHeader_Identify(sbody, "Date:") & vbTab & sBounceMessage & vbTab & sBounceType & vbNewLine
If bInteractiveMode Then
ShellAndWait "notepad """ & oFile.Path & """", vbNormalFocus
End If
End If


Else
WriteToConsole "Passed file due to unknown bounce [" & oFile.Name & "]."
oUnknownStream.WriteLine sDestinationFile & vbTab & oFile.Path & vbTab & "unknown_bounce"

If bInteractiveMode Then
ShellAndWait "notepad """ & oFile.Path & """", vbNormalFocus
End If
End If

'si non supprimés, non déplacés, non traités If (Not bDeleteFiles And Not bMoveFiles) Or Err Or sClientId "" Or sBounceType "0" Then
WriteToConsole " Not moved/deleted."
Else
If bDeleteFiles Then
oFile.Delete True
lFilesDeleted = lFilesDeleted + 1
WriteToConsole " Deleted."
ElseIf bMoveFiles Then
oFile.Move sMoveFolder & "" & oFile.Name
lFilesMoved = lFilesMoved + 1
WriteToConsole " Moved."
End If
End If

If Err Then
Err.Clear
oErrorStream.WriteLine sDestinationFile & vbTab & sClientOp & vbTab & oFile.Path & vbTab & "error"
lErrorsCount = lErrorsCount + 1
If i = j Then
lOpCount = lOpCount + 1
Else
i = j
j = aTempOp(i + 1)
End If
WriteToConsole " An error has occured."
If bInteractiveMode Then
ShellAndWait "notepad """ & oFile.Path & """", vbNormalFocus
End If
End If
'End If
End If
WriteToConsole vbNewLine
Set oFile = Nothing
End If
Next
On Error GoTo 0
Next
On Error GoTo 0

WriteToConsole "There is " & lFilesProcessed & " processed on " & lFilesCount & " file(s)." & vbNewLine
If lFilesDeleted > 0 Then WriteToConsole "There is " & lFilesDeleted & " file(s) deleted." & vbNewLine
If lFilesMoved > 0 Then WriteToConsole "There is " & lFilesMoved & " file(s) moved." & vbNewLine
If tFilesMoved > 0 Then WriteToConsole "There is " & tFilesMoved & " file(s) moved." & vbNewLine
If hFilesMoved > 0 Then WriteToConsole "There is " & hFilesMoved & " file(s) moved." & vbNewLine
If lMax > 0 Then WriteToConsole "Il y a " & lMax & " MaxFilesSize." & vbNewLine
'ajouter la notification dans le fichier destination.
'oDestinationStream.WriteLine "There is " & hFilesMoved & " file(s) moved."
If lErrorsCount > 0 Then WriteToConsole "--- WARNING !!! There is " & lErrorsCount & " error(s) occured. ---" & vbNewLine
WriteToConsole vbNewLine & "File [" & sDestinationFile & "] saved." & vbNewLine
oLogStream.WriteLine Now() & " - Processed " & lFilesProcessed & "/" & lFilesCount & ", " & lFilesDeleted & " deleted, " & lFilesMoved & " moved and " & lErrorsCount & " error(s)."
oDestinationStream.WriteLine "Il ya :" & lErrorsCount & "erreurs" & vbNewLine
If lOpCount > 0 Then oDestinationStream.WriteLine "Nombre d'erreur pour l'opération (" & sClientOp & "):" & lOpCount
'If i <> j Then
'oDestinationStream.WriteLine "=========================================================================="
'oDestinationStream.WriteLine "Client = [" & Mid(sSourceFolder, 4) & "]_(" & sClientId & ")" & vbNewLine
'oDestinationStream.WriteLine "--------------------------------------------------------------------------"
'oDestinationStream.WriteLine "Opération_Id = [" & sClientOp & "]" & vbNewLine
'oDestinationStream.WriteLine sNomFichier
'oDestinationStream.WriteLine sDateGeneration
'oDestinationStream.WriteLine "Nombre d'erreur pour l'opération (" & i & "):" & lErrorsCount
'oDestinationStream.WriteLine "==========================================================================="
'end If


Else
WriteToConsole vbNewLine & "Source folder [" & sSourceFolder & "] not found." & vbNewLine
oLogStream.WriteLine Now() & " - Source folder not found."
End If


oLogStream.WriteLine Now() & " - Processing end"


oUnknownStream.Close
Set oUnknownStream = Nothing
oErrorStream.Close
Set oErrorStream = Nothing
oLogStream.Close
Set oLogStream = Nothing
oDestinationStream.Close
Set oDestinationStream = Nothing


Set oFSO = Nothing


Call BounceSignature_Close



End Sub


Private Sub BounceSignature_Load()
Set oCnBounce = New ADODB.Connection
Set oRsBounce = New ADODB.Recordset
oCnBounce.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\bounce_signature.mdb;User Id=admin;Password=;"
oRsBounce.Open "SELECT * FROM bounce_signature ORDER BY weight DESC", oCnBounce, adOpenStatic, adLockBatchOptimistic
End Sub


Private Sub BounceSignature_Close()
oRsBounce.Close
Set oRsBounce = Nothing

oCnBounce.Close
Set oCnBounce = Nothing
End Sub


Private Function BounceSignature_Identify(ByVal Body As String) As String
BounceSignature_Identify = "0"


oRsBounce.MoveFirst
Do While Not oRsBounce.EOF
If InStr(1, Body, CStr(Trim(oRsBounce("signature"))), vbTextCompare) > 0 Then
BounceSignature_Identify = oRsBounce("weight") & ";" & oRsBounce("signature")
Exit Do
End If
oRsBounce.MoveNext
Loop
End Function


Private Function XHeader_Identify(ByVal Body As String, ByVal Header As String) As String
XHeader_Identify = ""

Dim lPos As Long, lLen As Long
lPos = InStr(Body, Header)
lLen = Len(Header)
If lPos <> 0 Then
XHeader_Identify = Trim(Mid(Body, lPos + lLen, InStr(lPos, Body, vbLf) - lPos - lLen - 1))
End If
End Function


Private Function WriteToConsole(sText As String) As Boolean
Dim lWritten As Long

If WriteFile(hOutput, ByVal sText, Len(sText), lWritten, ByVal 0) = 0 Then
WriteToConsole = False
Else
WriteToConsole = True
End If
End Function


Private Function ReadFromConsole() As String
Dim sBuffer As String * 256
Call ReadConsole(hInput, sBuffer, Len(sBuffer), vbNull, vbNull)
ReadFromConsole = Left(sBuffer, InStr(sBuffer, vbNullChar) - 3)
End Function


Private Sub ShellAndWait(ByVal ProgramName As String, ByVal WindowStyle As VbAppWinStyle)
Dim process_id As Long
Dim process_handle As Long

process_id = Shell(ProgramName, WindowStyle)

DoEvents

process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If
End Sub


'Private Function ParcourirSousDossier()
'For Each sFolder In oFolder.SubFolders


'End Function






Annick