A voir également:
- Exportation du corps d'un email provenant de
- Comment creer un compte email - Guide
- Télécharger le corps du desir en français - Forum TV & Vidéo
- Cci email - Guide
- Email hotmail - Guide
- Email gratuit - Guide
3 réponses
Salut à tous !
Bon et bien je n'ai pas encore eu de réponses, mais à vrai dire j'ai déjà pas mal avancé :)
Du coup, je reviendrai posté tout ça quand j'aurais terminé, ça pourrait surment en aider d'autre !
Peace :)
Bon et bien je n'ai pas encore eu de réponses, mais à vrai dire j'ai déjà pas mal avancé :)
Du coup, je reviendrai posté tout ça quand j'aurais terminé, ça pourrait surment en aider d'autre !
Peace :)
Bonjour !
Bon j'ai effectivement pas mal avancé ! Mais là je bloque et toute aide serait la bienvenue !
Donc je résume rapidement :
- Dans un premier temps je démarre une instance d'outlook si elle n'existe pas.
- Ensuite je m'occupe du fichier excel : je teste si il existe, sinon je le crée, puis je test si il est ouvert, sinon je l'ouvre.
-Après j'accède à la boite de réception, et pour chaque mail reçu : si l'objet et l'expéditeur du mail correspondent à ceux que j'ai déclaré dans des constantes, si il s'agit d'un message non lus, et si le corps du message n'est pas vide, je fais appel à ma pocédure d'insertion dans le fichier excel (je passe une variable string contenant le body du mail)
Exemple de corps du message :
Mon, 2009-10-26 09:08:54 - Access site - Source:10.120.128.2,WAN - Destination:liveupdate.symantecliveupdate.com,WAN - [Forward] Mon, 2009-10-26 09:10:46 - Access site - Source:10.120.128.2,WAN - Destination:mm.123cmail.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/picto/fr/90x90tth.gif,WAN Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:ads.leadium.com,WAN - [Forward] Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:wm.wizzms.com,WAN - [Forward] Mon, 2009-10-26 09:11:37 - Access site - Source:10.120.128.2,WAN - Destination:c.astrocenter.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/bigpicto/fr/300x250_fr2k2.jpg,WAN
Bon jusque là tout ce passe très bien, voici le code :
Code Visual Basic :Option Explicit
'J'utilise beaucoup de constante car ces informations peuvent varier.
Public Const NOM_FICHIER = "Rapport_"
Public Const EXT_FICHIER = ".xls"
Public Const REP_FICHIER = "D:\GARNIER\FG\Application\Rapport"
Public Const SEP_MSG_A = "WAN"
Public Const SEP_MSG_B = " - "
Public Const TYP_STR_A = "*blocked*"
Public Const TYP_STR_B = "*Access site*"
Public Const TYP_STR_C = " - Destination*"
Public Const CAR_SUP_A = "[FORWARD]"
Public Const CAR_SUP_B = "Source:"
Public Const CAR_SUP_C = "LAN"
Public Const CAR_SUP_D = ","
Public Const CAR_SUP_E = "Destination:"
Public message As String
Public Const ADR_MAIL = "nom@domaine.fr"
Public Const OBJ_MAIL = "NETGEAR Security Log [57:5A:C2]"
Public Const DOSSIER_ANALYSE = 6 'Correspond à la boite de réception
'Lance la récupération du corps du message
Sub RecuperationCorpsMsg()
ConnexionOutlook
End Sub
'Connexion à Outlook
Sub ConnexionOutlook()
Dim co_outlookapp As Object
Dim co_olnomdomaine As Object
Dim co_oldossier As Object
Dim co_olmailitem As Object
Dim co_flgoutlook As Boolean
Dim co_orderinfo As String
Dim co_cheminfichier As String
Dim co_flgfic As Boolean
co_flgfic = False
co_flgoutlook = False
co_orderinfo = ""
co_cheminfichier = ""
' Test de l'ouverture d'Outlook
Set co_outlookapp = CreateObject("Outlook.Application")
If co_outlookapp.Explorers.Count = 0 Then
co_flgoutlook = True
End If
' Création du répertoire
Creation_Repertoire (REP_FICHIER)
' Test si fichier Excel existe
Set xl_app = GetObject(, "Excel.Application")
co_cheminfichier = REP_FICHIER & "\" & NOM_FICHIER & EXT_FICHIER
If ExistFile(co_cheminfichier) Then
' Test si fichier ouvert
co_cheminfichier = NOM_FICHIER & EXT_FICHIER
If Fic_ouvert(co_cheminfichier) Then
Set xl_book = xl_app.Workbooks.Open(co_cheminfichier)
co_flgfic = True
Else
MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbCritical, _
"Tentative d'ouverture du fichier Excel"
co_flgfic = True
'End If
Else
'Procédure de création du fichier excel.
Creation_Mise_en_forme_Fichier_Excel
MsgBox "Le fichier Excel que vous souhaitiez ouvrir n'existait pas, il vient donc d'être créé.", _
vbOKOnly + vbInformation, "Test de l'existence du fichier Excel"
co_flgfic = True
End If
If co_flgfic Then
'Permet l'accès aux données stockées Outlook de l'utilisateur
Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
'Indique quel dossier doit être traité, ici le dossier contenant les emails utiles de la boite de réception
Set co_oldossier = co_olnomdomaine.GetDefaultFolder(DOSSIER_ANALYSE)
'Boucle permettant de traiter tout les messages de la boite de réception
For Each co_olmailitem In co_oldossier.Items
'Si l'objet du mail et l'adresse de l'expéditeur corresponddent,
If Trim(co_olmailitem.Subject) = OBJ_MAIL And Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then
'Si il ne s'agit pas d'un message déjà lu et traité
If co_olmailitem.UnRead = True Then
'Et si le corps du message n'est pas vide
If co_olmailitem.Body <> vbNullString Then
co_orderinfo = co_olmailitem.Body
'On fait appel à la procédure intégrant les informations dans le fichier Excel
InsertIntoExcel (co_orderinfo)
'On indique que le message est lu
co_olmailitem.UnRead = False
End If
End If
End If
Next
If co_orderinfo = "" Then
MsgBox "Il n'y aucune information à traiter !", _
vbOKOnly + vbInformation, "Enregistrement des Accès Internet"
Else
MsgBox "Toutes les informations ont été enregistrées dans le fichier Excel !", _
vbOKOnly + vbInformation, "Enregistrement des Accès Internet"
End If
End If
'Si on avai lancé une instance Outlook on la ferme
If co_flgoutlook Then
co_outlookapp.Quit
End If
'On décharge les objets en mémoire
Set co_oldossier = Nothing
Set co_olnomdomaine = Nothing
Set co_olmailitem = Nothing
Set co_outlookapp = Nothing
Set xl_app = Nothing
Set xl_book = Nothing
End Sub
C'est après que ça commence à moins marché !
Voici ma procédure pour insérer dans le fichier Excel :
Code Visual Basic :'Procédure permettant le traitement du message, et l'insertion dans le fichier Excel
Sub InsertIntoExcel(ByVal message As String)
Dim myarray() As String, myarrayb() As String, _
myarrayc() As String, myarrayd() As String, _
myarraye() As String, myarrayf() As String
Dim cheminfic As String
Dim i As Integer, _
m As Integer, n As Integer, o As Integer
Dim j As Integer, k As Integer, l As Integer
Dim x As Byte, y As Byte
Dim cel As Range, laplage As Range
'Initialisation des variables
cheminfic = ""
m = 0
n = 0
o = 0
cheminfic = REP_FICHIER
'On ouvre le fichier Excel
If Fic_ouvert(cheminfic) Then
Set xl_book = xl_app.Workbooks.Open(cheminfic)
End If
'Split de message avec comme paramètre "WAN" et stockage dans le tableau myArray
myarray = Split(message, SEP_MSG_A)
'Pour chaque ligne récupérée dans le tableau pendant le traitement du message
For i = 0 To UBound(myarray())
'Si il s'agit d'un site à accès bloqué, on insère la ligne dans le tableau myArrayB,
If myarray(i) Like TYP_STR_A Then
ReDim Preserve myarrayb(0 To m)
myarrayb(m) = ReplaceStr(myarray(i))
m = m + 1
'Sinon, si il s'agit d'un accès autorisé, on récupère le début de la chaine dans le tableau myArrayD
ElseIf myarray(i) Like TYP_STR_B Then
ReDim Preserve myarrayd(0 To n)
myarrayd(n) = ReplaceStr(myarray(i))
n = n + 1
'et on récupère la fin de cette chaine dans le tableau myArrayE (à cause de la précense des 2 "WAN"
'dans les chaines représentant un accès autorisé
ElseIf myarray(i) Like TYP_STR_C Then
ReDim Preserve myarraye(0 To o)
myarraye(o) = ReplaceStr(myarray(i))
o = o + 1
End If
Next i
With xl_book.Worksheets(1)
'Split de chaque ligne de myArrayB avec comme paramètre " - " et stockage dans le tableau myArrayC
For j = 0 To UBound(myarrayb())
myarrayc = Split(myarrayb(j), SEP_MSG_B)
ReDim Preserve myarrayc(0 To UBound(myarrayc()))
.Range("A" & j + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(myarrayc()) + 1) = myarrayc
Next j
'Split de chaque ligne de myArrayD associé à myArrayE avec comme paramètre " - " et stockage dans le tableau myArrayF
For k = 0 To UBound(myarrayd())
myarrayf = Split(myarrayd(k) & myarraye(k), SEP_MSG_B)
ReDim Preserve myarrayf(0 To UBound(myarrayf()))
.Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myarrayf()) + 1) = myarrayf
Next k
'Suppression Cellules Vides & Mise en forme
For l = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
With .Cells(l, 2)
If .Offset(0, -1).Text = "" Then
.Offset(0, -1).Delete xlToLeft
End If
End With
Next
'Permet la suppresion du jour (ex : "Mon") pour n'avoir que la date
Set laplage = .Range("A2:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In laplage
For x = 1 To Len(cel)
If IsNumeric(Mid(cel, x, 1)) Then
y = x
Exit For
End If
Next x
cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
Next cel
End With
'Destruction des tableaux dynamiques
Erase myarray
Erase myarrayb
Erase myarrayc
Erase myarrayd
Erase myarraye
Erase myarrayf
'On décharge les objets en mémoire
Set xl_app = Nothing
Set xl_book = Nothing
Set xl_sheet = Nothing
End Sub
'Fonction permettant de supprimer les informations inutiles
Function ReplaceStr(strch As String) As String
Dim replacestr1 As String, replacestr2 As String, replacestr3 As String, replacestr4 As String
replacestr1 = Replace(strch, CAR_SUP_A, "")
replacestr2 = Replace(replacestr1, CAR_SUP_B, "")
replacestr3 = Replace(replacestr2, CAR_SUP_C, "")
replacestr4 = Replace(replacestr3, CAR_SUP_D, " ")
ReplaceStr = Replace(replacestr4, CAR_SUP_E, "")
End Function
Et enfin voici mon erreur :
Erreur d'exécution 5 : Argument ou appel de procédure incorrect..
Sur la ligne suivante :
Code Visual Basic :cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
A un instant dans la boucle Len(cel) récupère la valeur zéro ce qui je pense fais planter la boucle.
Merci par avance, je sais que ça fait beaucoup de choses sur lequel se concentré, mais autant vous donner tout ce que j'ai c'est toujours plus simple pour comprendre !
Bonne journée à tous, Peace :)
Bon j'ai effectivement pas mal avancé ! Mais là je bloque et toute aide serait la bienvenue !
Donc je résume rapidement :
- Dans un premier temps je démarre une instance d'outlook si elle n'existe pas.
- Ensuite je m'occupe du fichier excel : je teste si il existe, sinon je le crée, puis je test si il est ouvert, sinon je l'ouvre.
-Après j'accède à la boite de réception, et pour chaque mail reçu : si l'objet et l'expéditeur du mail correspondent à ceux que j'ai déclaré dans des constantes, si il s'agit d'un message non lus, et si le corps du message n'est pas vide, je fais appel à ma pocédure d'insertion dans le fichier excel (je passe une variable string contenant le body du mail)
Exemple de corps du message :
Mon, 2009-10-26 09:08:54 - Access site - Source:10.120.128.2,WAN - Destination:liveupdate.symantecliveupdate.com,WAN - [Forward] Mon, 2009-10-26 09:10:46 - Access site - Source:10.120.128.2,WAN - Destination:mm.123cmail.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/picto/fr/90x90tth.gif,WAN Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:ads.leadium.com,WAN - [Forward] Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:wm.wizzms.com,WAN - [Forward] Mon, 2009-10-26 09:11:37 - Access site - Source:10.120.128.2,WAN - Destination:c.astrocenter.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/bigpicto/fr/300x250_fr2k2.jpg,WAN
Bon jusque là tout ce passe très bien, voici le code :
Code Visual Basic :Option Explicit
'J'utilise beaucoup de constante car ces informations peuvent varier.
Public Const NOM_FICHIER = "Rapport_"
Public Const EXT_FICHIER = ".xls"
Public Const REP_FICHIER = "D:\GARNIER\FG\Application\Rapport"
Public Const SEP_MSG_A = "WAN"
Public Const SEP_MSG_B = " - "
Public Const TYP_STR_A = "*blocked*"
Public Const TYP_STR_B = "*Access site*"
Public Const TYP_STR_C = " - Destination*"
Public Const CAR_SUP_A = "[FORWARD]"
Public Const CAR_SUP_B = "Source:"
Public Const CAR_SUP_C = "LAN"
Public Const CAR_SUP_D = ","
Public Const CAR_SUP_E = "Destination:"
Public message As String
Public Const ADR_MAIL = "nom@domaine.fr"
Public Const OBJ_MAIL = "NETGEAR Security Log [57:5A:C2]"
Public Const DOSSIER_ANALYSE = 6 'Correspond à la boite de réception
'Lance la récupération du corps du message
Sub RecuperationCorpsMsg()
ConnexionOutlook
End Sub
'Connexion à Outlook
Sub ConnexionOutlook()
Dim co_outlookapp As Object
Dim co_olnomdomaine As Object
Dim co_oldossier As Object
Dim co_olmailitem As Object
Dim co_flgoutlook As Boolean
Dim co_orderinfo As String
Dim co_cheminfichier As String
Dim co_flgfic As Boolean
co_flgfic = False
co_flgoutlook = False
co_orderinfo = ""
co_cheminfichier = ""
' Test de l'ouverture d'Outlook
Set co_outlookapp = CreateObject("Outlook.Application")
If co_outlookapp.Explorers.Count = 0 Then
co_flgoutlook = True
End If
' Création du répertoire
Creation_Repertoire (REP_FICHIER)
' Test si fichier Excel existe
Set xl_app = GetObject(, "Excel.Application")
co_cheminfichier = REP_FICHIER & "\" & NOM_FICHIER & EXT_FICHIER
If ExistFile(co_cheminfichier) Then
' Test si fichier ouvert
co_cheminfichier = NOM_FICHIER & EXT_FICHIER
If Fic_ouvert(co_cheminfichier) Then
Set xl_book = xl_app.Workbooks.Open(co_cheminfichier)
co_flgfic = True
Else
MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbCritical, _
"Tentative d'ouverture du fichier Excel"
co_flgfic = True
'End If
Else
'Procédure de création du fichier excel.
Creation_Mise_en_forme_Fichier_Excel
MsgBox "Le fichier Excel que vous souhaitiez ouvrir n'existait pas, il vient donc d'être créé.", _
vbOKOnly + vbInformation, "Test de l'existence du fichier Excel"
co_flgfic = True
End If
If co_flgfic Then
'Permet l'accès aux données stockées Outlook de l'utilisateur
Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
'Indique quel dossier doit être traité, ici le dossier contenant les emails utiles de la boite de réception
Set co_oldossier = co_olnomdomaine.GetDefaultFolder(DOSSIER_ANALYSE)
'Boucle permettant de traiter tout les messages de la boite de réception
For Each co_olmailitem In co_oldossier.Items
'Si l'objet du mail et l'adresse de l'expéditeur corresponddent,
If Trim(co_olmailitem.Subject) = OBJ_MAIL And Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then
'Si il ne s'agit pas d'un message déjà lu et traité
If co_olmailitem.UnRead = True Then
'Et si le corps du message n'est pas vide
If co_olmailitem.Body <> vbNullString Then
co_orderinfo = co_olmailitem.Body
'On fait appel à la procédure intégrant les informations dans le fichier Excel
InsertIntoExcel (co_orderinfo)
'On indique que le message est lu
co_olmailitem.UnRead = False
End If
End If
End If
Next
If co_orderinfo = "" Then
MsgBox "Il n'y aucune information à traiter !", _
vbOKOnly + vbInformation, "Enregistrement des Accès Internet"
Else
MsgBox "Toutes les informations ont été enregistrées dans le fichier Excel !", _
vbOKOnly + vbInformation, "Enregistrement des Accès Internet"
End If
End If
'Si on avai lancé une instance Outlook on la ferme
If co_flgoutlook Then
co_outlookapp.Quit
End If
'On décharge les objets en mémoire
Set co_oldossier = Nothing
Set co_olnomdomaine = Nothing
Set co_olmailitem = Nothing
Set co_outlookapp = Nothing
Set xl_app = Nothing
Set xl_book = Nothing
End Sub
C'est après que ça commence à moins marché !
Voici ma procédure pour insérer dans le fichier Excel :
Code Visual Basic :'Procédure permettant le traitement du message, et l'insertion dans le fichier Excel
Sub InsertIntoExcel(ByVal message As String)
Dim myarray() As String, myarrayb() As String, _
myarrayc() As String, myarrayd() As String, _
myarraye() As String, myarrayf() As String
Dim cheminfic As String
Dim i As Integer, _
m As Integer, n As Integer, o As Integer
Dim j As Integer, k As Integer, l As Integer
Dim x As Byte, y As Byte
Dim cel As Range, laplage As Range
'Initialisation des variables
cheminfic = ""
m = 0
n = 0
o = 0
cheminfic = REP_FICHIER
'On ouvre le fichier Excel
If Fic_ouvert(cheminfic) Then
Set xl_book = xl_app.Workbooks.Open(cheminfic)
End If
'Split de message avec comme paramètre "WAN" et stockage dans le tableau myArray
myarray = Split(message, SEP_MSG_A)
'Pour chaque ligne récupérée dans le tableau pendant le traitement du message
For i = 0 To UBound(myarray())
'Si il s'agit d'un site à accès bloqué, on insère la ligne dans le tableau myArrayB,
If myarray(i) Like TYP_STR_A Then
ReDim Preserve myarrayb(0 To m)
myarrayb(m) = ReplaceStr(myarray(i))
m = m + 1
'Sinon, si il s'agit d'un accès autorisé, on récupère le début de la chaine dans le tableau myArrayD
ElseIf myarray(i) Like TYP_STR_B Then
ReDim Preserve myarrayd(0 To n)
myarrayd(n) = ReplaceStr(myarray(i))
n = n + 1
'et on récupère la fin de cette chaine dans le tableau myArrayE (à cause de la précense des 2 "WAN"
'dans les chaines représentant un accès autorisé
ElseIf myarray(i) Like TYP_STR_C Then
ReDim Preserve myarraye(0 To o)
myarraye(o) = ReplaceStr(myarray(i))
o = o + 1
End If
Next i
With xl_book.Worksheets(1)
'Split de chaque ligne de myArrayB avec comme paramètre " - " et stockage dans le tableau myArrayC
For j = 0 To UBound(myarrayb())
myarrayc = Split(myarrayb(j), SEP_MSG_B)
ReDim Preserve myarrayc(0 To UBound(myarrayc()))
.Range("A" & j + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(myarrayc()) + 1) = myarrayc
Next j
'Split de chaque ligne de myArrayD associé à myArrayE avec comme paramètre " - " et stockage dans le tableau myArrayF
For k = 0 To UBound(myarrayd())
myarrayf = Split(myarrayd(k) & myarraye(k), SEP_MSG_B)
ReDim Preserve myarrayf(0 To UBound(myarrayf()))
.Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myarrayf()) + 1) = myarrayf
Next k
'Suppression Cellules Vides & Mise en forme
For l = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
With .Cells(l, 2)
If .Offset(0, -1).Text = "" Then
.Offset(0, -1).Delete xlToLeft
End If
End With
Next
'Permet la suppresion du jour (ex : "Mon") pour n'avoir que la date
Set laplage = .Range("A2:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In laplage
For x = 1 To Len(cel)
If IsNumeric(Mid(cel, x, 1)) Then
y = x
Exit For
End If
Next x
cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
Next cel
End With
'Destruction des tableaux dynamiques
Erase myarray
Erase myarrayb
Erase myarrayc
Erase myarrayd
Erase myarraye
Erase myarrayf
'On décharge les objets en mémoire
Set xl_app = Nothing
Set xl_book = Nothing
Set xl_sheet = Nothing
End Sub
'Fonction permettant de supprimer les informations inutiles
Function ReplaceStr(strch As String) As String
Dim replacestr1 As String, replacestr2 As String, replacestr3 As String, replacestr4 As String
replacestr1 = Replace(strch, CAR_SUP_A, "")
replacestr2 = Replace(replacestr1, CAR_SUP_B, "")
replacestr3 = Replace(replacestr2, CAR_SUP_C, "")
replacestr4 = Replace(replacestr3, CAR_SUP_D, " ")
ReplaceStr = Replace(replacestr4, CAR_SUP_E, "")
End Function
Et enfin voici mon erreur :
Erreur d'exécution 5 : Argument ou appel de procédure incorrect..
Sur la ligne suivante :
Code Visual Basic :cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
A un instant dans la boucle Len(cel) récupère la valeur zéro ce qui je pense fais planter la boucle.
Merci par avance, je sais que ça fait beaucoup de choses sur lequel se concentré, mais autant vous donner tout ce que j'ai c'est toujours plus simple pour comprendre !
Bonne journée à tous, Peace :)
Je rajoute une petite chose. Le code suivant marche parfaitement, me colle tous aux bons endroits dans le fichier Excel : je passe une chaine de caractères en paramètre. Donc ici, je ne fait pas encore ajouter l'ouverture d'outlook, le traitement ne se fait pas non plus sur le corps du message mais bien sur une chaine (strChaine).
Voici le code, vous pouvez le tester dans un nouveau module sur une feuille vierge. Il faut juste créer un autre classeur nommé "Rapport.xls", j'ai juste mit des titres:
A1 -> Date et Heure
B1 -> Type d'accès
C1 -> Source
D1 -> Destination
(La variable contenant le chemin est bien sûr à modifier, je l'ai soulignée, mise en italique et en gras !)
Option Explicit
Sub EssaiExtractInfo2()
Dim strChaine As String
strChaine = "Mon, 2009-10-26 09:08:54 - Access site - Source:10.120.128.2,WAN - Destination:liveupdate.symantecliveupdate.com,WAN - [Forward] Mon, 2009-10-26 09:10:46 - Access site - Source:10.120.128.2,WAN - Destination:mm.123cmail.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/picto/fr/90x90tth.gif,WAN Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:ads.leadium.com,WAN - [Forward] Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:wm.wizzms.com,WAN - [Forward] Mon, 2009-10-26 09:11:37 - Access site - Source:10.120.128.2,WAN - Destination:c.astrocenter.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/bigpicto/fr/300x250_fr2k2.jpg,WAN"
InsertIntoExcel (strChaine)
End Sub
'Procédure permettant le traitement du message, et l'insertion dans le fichier Excel
Sub InsertIntoExcel(ByVal message As String)
Dim myArray() As String, myArrayB() As String, _
myArrayC() As String, myArrayD() As String, _
myArrayE() As String, myArrayF() As String, _
myArrayG() As String, myArrayH() As String
Dim xlApp As Excel.Application
Dim xl_Book As Excel.Workbook
Dim xl_Sheet As Excel.Worksheet
Dim xlApp_Cree As Boolean
Dim xl_Book_Cree As Boolean
Dim cheminFic As String
Dim i As Integer, _
m As Integer, n As Integer, o As Integer, p As Integer
Dim j As Integer, k As Integer, l As Integer
Dim q As Integer
Dim x As Byte, y As Byte
Dim cel As Range, laPlage As Range
'Initialisation des variables
cheminFic = ""
m = 0
n = 0
o = 0
p = 0
'Evite le message d'erreur lors du test de l'existence de l'instance Excel
On Error Resume Next
'Test l'existence d'une instance Excel
Set xlApp = GetObject(, "Excel.Application")
'Si il n'y en a pas on la crée
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp_Cree = True
Else
xl_Book_Cree = True
End If
On Error GoTo 0
'On ouvre le fichier Excel
cheminFic = "D:\GARNIER\FG\Application\Rapport\Rapport_.xls"
Set xl_Book = xlApp.Workbooks.Open(cheminFic)
Set xl_Sheet = xl_Book.ActiveSheet
'Split de message avec comme paramètre "WAN" et stockage dans le tableau myArray
myArray = Split(message, "WAN")
'Pour chaque ligne récupérée dans le tableau pendant le traitement du message
For i = 0 To UBound(myArray())
'Si il s'agit d'un site à accès bloqué, on insère la ligne dans le tableau myArrayB,
If myArray(i) Like "*blocked*" Then
ReDim Preserve myArrayB(0 To m)
myArrayB(m) = ReplaceStr(myArray(i))
m = m + 1
'Sinon, si il s'agit d'un accès autorisé, on récupère le début de la chaine dans le tableau myArrayD
ElseIf myArray(i) Like "*Access site*" Then
ReDim Preserve myArrayD(0 To n)
myArrayD(n) = ReplaceStr(myArray(i))
n = n + 1
'et on récupère la fin de cette chaine dans le tableau myArrayE (à cause de la précense des 2 "WAN"
'dans les chaines représentant un accès autorisé
ElseIf myArray(i) Like " - Destination*" Then
ReDim Preserve myArrayE(0 To o)
myArrayE(o) = ReplaceStr(myArray(i))
o = o + 1
ElseIf myArray(i) Like "*IP packet*" Then
ReDim Preserve myArrayG(0 To p)
myArrayG(p) = ReplaceStr(myArray(i))
p = p + 1
End If
Next i
With xl_Sheet
'Split de chaque ligne de myArrayB avec comme paramètre " - " et stockage dans le tableau myArrayC
For j = 0 To UBound(myArrayB())
myArrayC = Split(myArrayB(j), " - ")
ReDim Preserve myArrayC(0 To UBound(myArrayC()))
.Range("A" & j + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(myArrayC()) + 1) = myArrayC
Next j
'Split de chaque ligne de myArrayD associé à myArrayE avec comme paramètre " - " et stockage dans le tableau myArrayF
For k = 0 To UBound(myArrayD())
myArrayF = Split(myArrayD(k) & myArrayE(k), " - ")
ReDim Preserve myArrayF(0 To UBound(myArrayF()))
.Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myArrayF()) + 1) = myArrayF
Next k
For q = 0 To UBound(myArrayG())
myArrayH = Split(myArrayG(q), " - ")
ReDim Preserve myArrayH(0 To UBound(myArrayH()))
.Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myArrayH()) + 1) = myArrayH
Next q
'Suppression Cellules Vides & Mise en forme
For l = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
With .Cells(l, 2)
If .Offset(0, -1).Text = "" Then
.Offset(0, -1).Delete xlToLeft
End If
End With
Next
'Permet la suppresion du jour (ex : "Mon") pour n'avoir que la date
Set laPlage = .Range("A2:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In laPlage
For x = 1 To Len(cel)
If IsNumeric(Mid(cel, x, 1)) Then
y = x
Exit For
End If
Next x
'Pb depuis l'ajout de l'ouverture du fichier
If Len(cel) <> 0 Then
cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
End If
Next cel
End With
'Destruction des tableaux dynamiques
Erase myArray
Erase myArrayB
Erase myArrayC
Erase myArrayD
Erase myArrayE
Erase myArrayF
'Si on avai lancé une instance Excel on la ferme
If xlApp_Cree Then
xlApp.Quit
ElseIf xl_Book_Cree Then
xl_Book.Close
End If
'On décharge les objets en mémoire
Set xlApp = Nothing
Set xl_Book = Nothing
Set xl_Sheet = Nothing
End Sub
'Fonction permettant de supprimer les informations inutiles
Function ReplaceStr(strCh As String) As String
Dim replaceStr1 As String, replaceStr2 As String, replaceStr3 As String, replaceStr4 As String, replaceStr5 As String
replaceStr1 = Replace(strCh, "[Forward]", "")
replaceStr2 = Replace(replaceStr1, "Source:", "")
replaceStr3 = Replace(replaceStr2, "LAN", "")
replaceStr4 = Replace(replaceStr3, ",", " ")
replaceStr5 = Replace(replaceStr4, "Destination:", "")
ReplaceStr = Replace(replaceStr5, " [Drop] - [Targa3 Attack] ", "")
End Function
Merci d'avance, bonne journée !
Peace :)
Voici le code, vous pouvez le tester dans un nouveau module sur une feuille vierge. Il faut juste créer un autre classeur nommé "Rapport.xls", j'ai juste mit des titres:
A1 -> Date et Heure
B1 -> Type d'accès
C1 -> Source
D1 -> Destination
(La variable contenant le chemin est bien sûr à modifier, je l'ai soulignée, mise en italique et en gras !)
Option Explicit
Sub EssaiExtractInfo2()
Dim strChaine As String
strChaine = "Mon, 2009-10-26 09:08:54 - Access site - Source:10.120.128.2,WAN - Destination:liveupdate.symantecliveupdate.com,WAN - [Forward] Mon, 2009-10-26 09:10:46 - Access site - Source:10.120.128.2,WAN - Destination:mm.123cmail.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/picto/fr/90x90tth.gif,WAN Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:ads.leadium.com,WAN - [Forward] Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:wm.wizzms.com,WAN - [Forward] Mon, 2009-10-26 09:11:37 - Access site - Source:10.120.128.2,WAN - Destination:c.astrocenter.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/bigpicto/fr/300x250_fr2k2.jpg,WAN"
InsertIntoExcel (strChaine)
End Sub
'Procédure permettant le traitement du message, et l'insertion dans le fichier Excel
Sub InsertIntoExcel(ByVal message As String)
Dim myArray() As String, myArrayB() As String, _
myArrayC() As String, myArrayD() As String, _
myArrayE() As String, myArrayF() As String, _
myArrayG() As String, myArrayH() As String
Dim xlApp As Excel.Application
Dim xl_Book As Excel.Workbook
Dim xl_Sheet As Excel.Worksheet
Dim xlApp_Cree As Boolean
Dim xl_Book_Cree As Boolean
Dim cheminFic As String
Dim i As Integer, _
m As Integer, n As Integer, o As Integer, p As Integer
Dim j As Integer, k As Integer, l As Integer
Dim q As Integer
Dim x As Byte, y As Byte
Dim cel As Range, laPlage As Range
'Initialisation des variables
cheminFic = ""
m = 0
n = 0
o = 0
p = 0
'Evite le message d'erreur lors du test de l'existence de l'instance Excel
On Error Resume Next
'Test l'existence d'une instance Excel
Set xlApp = GetObject(, "Excel.Application")
'Si il n'y en a pas on la crée
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp_Cree = True
Else
xl_Book_Cree = True
End If
On Error GoTo 0
'On ouvre le fichier Excel
cheminFic = "D:\GARNIER\FG\Application\Rapport\Rapport_.xls"
Set xl_Book = xlApp.Workbooks.Open(cheminFic)
Set xl_Sheet = xl_Book.ActiveSheet
'Split de message avec comme paramètre "WAN" et stockage dans le tableau myArray
myArray = Split(message, "WAN")
'Pour chaque ligne récupérée dans le tableau pendant le traitement du message
For i = 0 To UBound(myArray())
'Si il s'agit d'un site à accès bloqué, on insère la ligne dans le tableau myArrayB,
If myArray(i) Like "*blocked*" Then
ReDim Preserve myArrayB(0 To m)
myArrayB(m) = ReplaceStr(myArray(i))
m = m + 1
'Sinon, si il s'agit d'un accès autorisé, on récupère le début de la chaine dans le tableau myArrayD
ElseIf myArray(i) Like "*Access site*" Then
ReDim Preserve myArrayD(0 To n)
myArrayD(n) = ReplaceStr(myArray(i))
n = n + 1
'et on récupère la fin de cette chaine dans le tableau myArrayE (à cause de la précense des 2 "WAN"
'dans les chaines représentant un accès autorisé
ElseIf myArray(i) Like " - Destination*" Then
ReDim Preserve myArrayE(0 To o)
myArrayE(o) = ReplaceStr(myArray(i))
o = o + 1
ElseIf myArray(i) Like "*IP packet*" Then
ReDim Preserve myArrayG(0 To p)
myArrayG(p) = ReplaceStr(myArray(i))
p = p + 1
End If
Next i
With xl_Sheet
'Split de chaque ligne de myArrayB avec comme paramètre " - " et stockage dans le tableau myArrayC
For j = 0 To UBound(myArrayB())
myArrayC = Split(myArrayB(j), " - ")
ReDim Preserve myArrayC(0 To UBound(myArrayC()))
.Range("A" & j + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(myArrayC()) + 1) = myArrayC
Next j
'Split de chaque ligne de myArrayD associé à myArrayE avec comme paramètre " - " et stockage dans le tableau myArrayF
For k = 0 To UBound(myArrayD())
myArrayF = Split(myArrayD(k) & myArrayE(k), " - ")
ReDim Preserve myArrayF(0 To UBound(myArrayF()))
.Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myArrayF()) + 1) = myArrayF
Next k
For q = 0 To UBound(myArrayG())
myArrayH = Split(myArrayG(q), " - ")
ReDim Preserve myArrayH(0 To UBound(myArrayH()))
.Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myArrayH()) + 1) = myArrayH
Next q
'Suppression Cellules Vides & Mise en forme
For l = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
With .Cells(l, 2)
If .Offset(0, -1).Text = "" Then
.Offset(0, -1).Delete xlToLeft
End If
End With
Next
'Permet la suppresion du jour (ex : "Mon") pour n'avoir que la date
Set laPlage = .Range("A2:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In laPlage
For x = 1 To Len(cel)
If IsNumeric(Mid(cel, x, 1)) Then
y = x
Exit For
End If
Next x
'Pb depuis l'ajout de l'ouverture du fichier
If Len(cel) <> 0 Then
cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
End If
Next cel
End With
'Destruction des tableaux dynamiques
Erase myArray
Erase myArrayB
Erase myArrayC
Erase myArrayD
Erase myArrayE
Erase myArrayF
'Si on avai lancé une instance Excel on la ferme
If xlApp_Cree Then
xlApp.Quit
ElseIf xl_Book_Cree Then
xl_Book.Close
End If
'On décharge les objets en mémoire
Set xlApp = Nothing
Set xl_Book = Nothing
Set xl_Sheet = Nothing
End Sub
'Fonction permettant de supprimer les informations inutiles
Function ReplaceStr(strCh As String) As String
Dim replaceStr1 As String, replaceStr2 As String, replaceStr3 As String, replaceStr4 As String, replaceStr5 As String
replaceStr1 = Replace(strCh, "[Forward]", "")
replaceStr2 = Replace(replaceStr1, "Source:", "")
replaceStr3 = Replace(replaceStr2, "LAN", "")
replaceStr4 = Replace(replaceStr3, ",", " ")
replaceStr5 = Replace(replaceStr4, "Destination:", "")
ReplaceStr = Replace(replaceStr5, " [Drop] - [Targa3 Attack] ", "")
End Function
Merci d'avance, bonne journée !
Peace :)
Bonjour bonjour !
J'ai finalement enfin terminé^^
Je vous envoi ce lien si la solution vous intéressent :
[URL="https://www.developpez.net/forums/d831335-2/logiciels/microsoft-office/excel/macros-vba-excel/exportation-corps-d-email-provenant-outlook-vers-fichier-excel/"]Solution au problème[/URL].
J'y est posté l'ensemble de mon appli, enfin j'ai posté tous mes modules, et je vous explique comment faire si vous voulez tester et voir ce que ça fait !!
Peace :)
J'ai finalement enfin terminé^^
Je vous envoi ce lien si la solution vous intéressent :
[URL="https://www.developpez.net/forums/d831335-2/logiciels/microsoft-office/excel/macros-vba-excel/exportation-corps-d-email-provenant-outlook-vers-fichier-excel/"]Solution au problème[/URL].
J'y est posté l'ensemble de mon appli, enfin j'ai posté tous mes modules, et je vous explique comment faire si vous voulez tester et voir ce que ça fait !!
Peace :)
Bonjour bonjour !
J'ai finalement enfin terminé^^
Je vous envoi ce lien si la solution vous intéressent :
https://www.developpez.net/forums/d831335-2/logiciels/microsoft-office/excel/macros-vba-excel/exportation-corps-d-email-provenant-outlook-vers-fichier-excel/
J'y est posté l'ensemble de mon appli, enfin j'ai posté tous mes modules, et je vous explique comment faire si vous voulez tester et voir ce que ça fait !!
Peace :)
J'ai finalement enfin terminé^^
Je vous envoi ce lien si la solution vous intéressent :
https://www.developpez.net/forums/d831335-2/logiciels/microsoft-office/excel/macros-vba-excel/exportation-corps-d-email-provenant-outlook-vers-fichier-excel/
J'y est posté l'ensemble de mon appli, enfin j'ai posté tous mes modules, et je vous explique comment faire si vous voulez tester et voir ce que ça fait !!
Peace :)
