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
| Sub ExtractInfo()
Dim MyArray() As String, MyArrayB() As String, _
MyArrayC() As String, MyArrayD() As String, _
MyArrayE() As String, MyArrayF() As String, _
strChaine As String
Dim i As Integer, j As Integer, k As Integer, _
p As Integer, q As Integer, t As Integer, _
n As Integer
Dim x As Byte, y As Byte
Dim Cel As Range, LaPlage As Range
'/***** Initialisation des variables *****/'
j = 0
p = 0
q = 0
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"
'/******** Split de strChaine avec comme paramètre "WAN" et
'/ stockage dans une var. Tableau *******/'
MyArray = Split(strChaine, "WAN")
For i = 0 To UBound(MyArray())
If MyArray(i) Like "*blocked*" Then
ReDim Preserve MyArrayB(0 To j)
MyArrayB(j) = ReplaceStr(MyArray(i))
j = j + 1
ElseIf MyArray(i) Like "*Access site*" Then
ReDim Preserve MyArrayD(0 To p)
MyArrayD(p) = ReplaceStr(MyArray(i))
p = p + 1
ElseIf MyArray(i) Like " - Destination*" Then
ReDim Preserve MyArrayE(0 To q)
MyArrayE(q) = ReplaceStr(MyArray(i))
q = q + 1
End If
Next i
With Worksheets("Feuil1") ' A adapter en fontion du nom de la feuille Cible
'/******** Split de chaque ligne de MyArrayB avec comme
'/ paramètre " - " et stockage dans une var. Tableau *******/'
For k = 0 To UBound(MyArrayB())
MyArrayC = Split(MyArrayB(k), " - ")
ReDim Preserve MyArrayC(0 To UBound(MyArrayC()))
Range("A" & k + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(MyArrayC()) + 1) = MyArrayC
Next k
For t = 0 To UBound(MyArrayD())
MyArrayF = Split(MyArrayD(t) & MyArrayE(t), " - ")
ReDim Preserve MyArrayF(0 To UBound(MyArrayF()))
Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(MyArrayF()) + 1) = MyArrayF
Next t
'/************ Supp. Cells Vides & Mise en forme ******
'/*****************************************************
For n = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
With .Cells(n, 2)
If .Offset(0, -1).Text = "" Then .Offset(0, -1).Delete xlToLeft
End With
Next
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 = Mid(Cel.Text, y, Len(Cel) - y + 1)
Next Cel
End With
Erase MyArray
Erase MyArrayB
Erase MyArrayC
Erase MyArrayD
Erase MyArrayE
Erase MyArrayF
End Sub
Function ReplaceStr(strCh As String) As String
Dim ReplaceStr1 As String, ReplaceStr2 As String, _
ReplaceStr3 As String, ReplaceStr4 As String
ReplaceStr1 = Replace(strCh, "[Forward]", "")
ReplaceStr2 = Replace(ReplaceStr1, "Source:", "")
ReplaceStr3 = Replace(ReplaceStr2, "LAN", "")
ReplaceStr4 = Replace(ReplaceStr3, ",", " ")
ReplaceStr = Replace(ReplaceStr4, "Destination:", "")
End Function |
Exportation du corps d'un email provenant de outlook vers un fichier excel
Répondre avec citation
mais il reste un peu de boulot 
^^
Partager