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
| Sub Classement()
Dim myinspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim email As String
Dim doss As String
Dim creation As String
Dim societe As String
Dim Nom As String
Dim Prenom As String
Dim Dossier As String
Dim intFic As Integer
Dim strLigne As String
Dim Dossecriture As String
Dim olObj As Object
'Note: Must have set reference to:
'Microsoft Excel 14.0 Object Library
'This is accessed in the VBE Editor
'Under Tools -> References...
Set olObj = Application.ActiveInspector.CurrentItem
HisMail = olObj.Recipients.Item(1).Address
Set olObj = Nothing
Set myinspector = Application.ActiveInspector
Set myItem = myinspector.CurrentItem
'Detection du mail ouvert pour recuperer ses informations
Objet = myItem.Subject
'Prend l'objet du mail
Objet = Replace(Objet, ":", " ")
Objet = Replace(Objet, ".", " ")
' Enleve les carateres interdit
heure = myItem.ReceivedTime
'Prend l'heure de email
email = myItem.SenderEmailAddress
'Prend l'adresse email
doss = "C:\Users\Secrétariat2\Desktop\CESAR\client\gestion\" & email
texte = doss & "\" & "chemin.txt"
If Dir(doss, vbDirectory) = "" Then
MkDir (doss)
creation = "oui"
Else
creation = "non"
End If
If (creation = "oui") Then
societe = InputBox("Le client apparait pas dans notre base" & vbCrLf & vbCrLf & _
"Sa societé ?", "Creation fiche client")
'On demande La societé
Nom = InputBox("Son NOM en majuscule svp" & vbCrLf & vbCrLf & _
"Son Nom ?", "Creation fiche client")
'On demande le Nom
Prenom = InputBox("Son Prenom avec la premiere lettre en majuscule" & vbCrLf & vbCrLf & _
"Son Prenom ?", "Creation de ca fiche")
'On demande le prenom
societe = UCase(societe)
Nom = UCase(Nom)
Prenom = LCase(Prenom)
Dossier = "C:\Users\Secrétariat2\Desktop\CESAR\client" & "\" & societe & "_" & Prenom & "_" & Nom
If Dir(Dossier, vbDirectory) = "" Then
MkDir (Dossier)
Const ForReading = 1, ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(texte, ForWriting, True)
f.Write (Dossier)
Dossecriture = Dossier & "\"
End If
Else
intFic = FreeFile
Open texte For Input As intFic
Line Input #intFic, strLigne
Close intFic
Dossecriture = Dossier & "\"
End If
Set objCurrentMessage = ActiveInspector.CurrentItem
repertoire = Dossecriture & Objet
PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", "-"), ":", "#"), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
n = 1
MemPath = PathNomExport
While Dir(PathNomExport) <> ""
MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
n = n + 1
Wend
objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
End Sub
Sub LanceSurOuvert()
sav_mail_as_msg
End Sub
Sub LanceSurSelection()
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails As Outlook.Selection
Set MonOutlook = Outlook.Application
Set LesMails = MonOutlook.ActiveExplorer.Selection
For Each LeMail In LesMails
sav_mail_as_msg LeMail
Next LeMail
Set LesMails = Nothing
MsgBox "Fin de traitement"
End Sub |
probleme sauvegarde mail
Répondre avec citation
Oliv'
Envoyé par Oliv-
Partager