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
| Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim sSenderEmailAddress As String
Dim res As Integer
Dim xlDialogSaveAs
Dim Message, Title, Default, MyValue
Message = "Où voulez-vous enregistrer la sélection ?"
Title = "Sélection du répertoire de sauvegarde "
Default = "C:\Users\packt\Desktop\CopieMail\"
sPath = InputBox(Message, Title, Default)
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
sName = StrConv(sName, vbProperCase)
ReplaceCharsForFileName sName, ""
dtDate = oMail.ReceivedTime
sSenderEmailAddress = oMail.SenderName
res = InStr(1, sSenderEmailAddress, ",")
If res = 0 Then
sSenderEmailAddress = Left(sSenderEmailAddress, 10)
Else
sSenderEmailAddress = Left(sSenderEmailAddress, InStr(sSenderEmailAddress, ",") + 2)
End If
ReplaceCharsForFileName sSenderEmailAddress, ""
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & "_" & Format(dtDate, "hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & "_" & sSenderEmailAddress & "_" & sName & ".msg"
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
sName = Replace(sName, " ", sChr)
sName = Replace(sName, ",", sChr)
End Sub |
