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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
| Option Explicit
Const cStartMail As String = "SMTP:" ' Début de l'email
Const cEndMail As String = " " ' Fin de l'email
Const cPrenomNom As String = "." ' Séparateur du Prénom et du Nom
Const cNomSociety As String = "@" ' Séparateur du Nom et de la société
Const cSocietyTld As String = "." ' Séparateur de la socété et le Top Level Domaine
Dim strLigne As String ' Contenu de la ligne
Dim lgPosCurseur As Long ' Positon du curseur dans le texte
Dim lgRows As Long
Sub FindMail()
Dim intFic As Integer
Dim temp As Long '*
' Initialisation des variables
strLigne = Empty
lgRows = 2
subMiseEnpage
intFic = FreeFile
Open funcOpenFile For Input As intFic
While Not EOF(intFic)
' Lecture de la ligne
Line Input #intFic, strLigne
lgPosCurseur = 1
While lgPosCurseur < Len(strLigne)
'MsgBox strLigne
' Recherche du debut de l'email
If Mid(strLigne, lgPosCurseur, Len(cStartMail)) = cStartMail Then ' Mid( zone de rech, position du curseur , longeur) = valeur désiré. Len (chaine de caractere) extrait la longeur de la chaine de carac
'Recherche information
subFindData
Else:
lgPosCurseur = lgPosCurseur + 1 ' Déplacement du curseur
End If
Wend
Wend
Close intFic
End Sub
' ###########################################################
' ###########################################################
' Recherche des données
Private Sub subFindData()
Dim lgPosStart As Long 'Position de début des données
Dim lgPosStartTemp As Long 'Position de début de données suplémentaires
Dim lgPosEnd As Long 'Position de fin des données
Dim stMail As String ' Mémorisation de l'adresse Mail
Dim stPrenom As String ' Mémorisation du prénom
Dim stNom As String ' Mémorisation du nom
Dim stSociety As String ' Mémorisation de la société
' Initialisation des variables
lgPosCurseur = lgPosCurseur + Len(cStartMail) 'Positionnement du curseur en début de données
lgPosStart = lgPosCurseur
lgPosStartTemp = 0
stMail = Empty
stPrenom = Empty
stNom = Empty
stSociety = Empty
While stMail = Empty
If Mid(strLigne, lgPosCurseur, Len(cEndMail)) = cEndMail Or lgPosCurseur = Len(strLigne) Then
stMail = Mid(strLigne, lgPosStart, lgPosCurseur - lgPosStart) ' Enreg de l'adresse Mail
' Prénom
ElseIf Mid(strLigne, lgPosCurseur, 1) = cPrenomNom And stNom = Empty Then
If stPrenom = Empty Then
stPrenom = Mid(strLigne, lgPosStart, lgPosCurseur - lgPosStart) ' Enreg du prénom
lgPosStartTemp = lgPosCurseur + Len(cPrenomNom)
Else: stPrenom = stPrenom & "(" & Mid(strLigne, lgPosStartTemp, lgPosCurseur - lgPosStartTemp) & ")"
End If
' Nom
ElseIf Mid(strLigne, lgPosCurseur, 1) = cNomSociety Then
lgPosStartTemp = lgPosStart + Len(stPrenom) + Len(cPrenomNom)
stNom = Mid(strLigne, lgPosStartTemp, lgPosCurseur - lgPosStartTemp) ' Enreg du nom
ElseIf Mid(strLigne, lgPosCurseur, 1) = cSocietyTld And stSociety = Empty And stNom <> Empty Then ' Pour trouver une société, le nom doit être renseigné
lgPosStartTemp = lgPosStartTemp + Len(stNom) + Len(cNomSociety)
stSociety = Mid(strLigne, lgPosStartTemp, lgPosCurseur - lgPosStartTemp) ' Enreg de la société
End If
lgPosCurseur = lgPosCurseur + 1 ' Déplacement du curseur
Wend
' Affichage des données trouvées
Call subDisplayData(stMail, stPrenom, stNom, stSociety)
End Sub
' ###########################################################
' ###########################################################
' Ouvrir une boite de dialogue pour rechercher le fichier source
Private Function funcOpenFile() As Variant
'Affiche la boîte de dialogue "Ouvrir"
funcOpenFile = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
' funcOpenFile = Fichier
'On sort si aucun fichier n'a été sélectionné ou si l'utilisateur
'a cliqué sur le bouton "Annuler", ou sur la croix de fermeture.
If funcOpenFile = False Then Exit Function
End Function
' ###########################################################
' ###########################################################
Private Sub subDisplayData(strMail As String, strPrenom As String, strNom As String, strSociety As String)
Cells(lgRows, 1).FormulaR1C1 = strPrenom ' Affichage du Prénom
Cells(lgRows, 2).FormulaR1C1 = strNom ' Affichage du Nom
Cells(lgRows, 3).FormulaR1C1 = strSociety ' Affichage du Society
Cells(lgRows, 4).FormulaR1C1 = strMail ' Affichage du Mail
lgRows = lgRows + 1
End Sub
' ###########################################################
' ###########################################################
Private Sub subMiseEnpage()
' Effacer classeur
Cells.Select
Selection.ClearContents
' Titre des colonnes
ActiveCell.FormulaR1C1 = "Prénom"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Nom"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Société"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Email"
' Mise en forme de la 1° ligne : centré, gras, filtres
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Selection.AutoFilter
End Sub |
Répondre avec citation
Partager