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
| Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'Structure du fichier
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Function EnregistrerUnFichier(Handle As Long, Titre As String, _
NomFichier As String, Chemin As String) As String
'EnregistrerUnFichier est la fonction a utiliser dans votre formulaire pour ouvrir _
la boîte de dialogue d'enregistrement d'un fichier.
'Explication des paramètres
'Handle = le handle de la fenêtre (Me.Hwnd)
'Titre = Titre de la boîte de dialogue
'NomFichier = Nom par défaut du fichier à enregistrer
'Chemin = Chemin par défaut du fichier à enregistrer
Dim structSave As OPENFILENAME
With structSave
.lStructSize = Len(structSave)
.hWndOwner = Handle
.nMaxFile = 255
.lpstrFile = NomFichier & String$(255 - Len(NomFichier), 0)
.lpstrInitialDir = Chemin
.lpstrFilter = "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0) 'Définition du filtre (aucun)
.Flags = &H4 'Option de la boite de dialogue
End With
If (GetSaveFileName(structSave)) Then
EnregistrerUnFichier = Mid$(structSave.lpstrFile, 1, InStr(1, structSave.lpstrFile, vbNullChar) - 1)
End If
End Function
Sub Extrait_Pieces_Jointes()
'----------------------------------------------------------------------
' Routine : Extrait_Pieces_Jointes
' retour : Boite de dialogue "Terminé"
'----------------------------------------------------------------------
Dim myNameSpace As NameSpace, fld As MAPIFolder, pfld As MAPIFolder, sfld As MAPIFolder
Dim myItem As MailItem, Piece As Attachment
Dim doc As String, rep As String, REP_TOP As String
'-- Récupération de l'espace nommé MAPI
Set myNameSpace = CreateObject("Outlook.Application").GetNamespace("MAPI")
'-- Choix du dossier à traiter ... c'est un MAPIFolder
Set pfld = myNameSpace.PickFolder
'-- Si l'utilisateur renonce on s'en va
If pfld Is Nothing Then Exit Sub
'-- appel de la routine sauvefolder ...
sauvefolder pfld, ""
MsgBox "terminé"
End Sub
Sub sauvefolder(fld As MAPIFolder, ByVal suf As String)
' Paramètres :
' fld : Le MAPIFolder à traiter
' suf : localisation /nomdedossier/nomdedossier2/
'-- on entretient la localisation sur la base du nom de dossier courant
suf = suf & fld.Name & "\"
'-- On envoie une info dans la fenêtre debug pour ceux qui aiment voir ce qui se passe
Debug.Print suf & fld.Items.Count
'-- On tourne sur tous les éléments du dossier courant
For i = 1 To fld.Items.Count
'-- Si c'est un élément de type Mail alors on sauvegarde les pièces jointes associées
If fld.Items(i).Class = olMail Then sauvefichier fld.Items(i), suf
'-- Pour voir ce qui se passe sans tout faire ... enlever le commentaire ci-dessous
'If i = 2 Then Exit For
Next
'-- On tourne sur tous les sous-dossiers du dossier courant
For i = 1 To fld.Folders.Count
'-- appel récursif de la fonction sauvefolder
sauvefolder fld.Folders(i), suf
Next
End Sub
Sub sauvefichier(myItem As MailItem, ByVal suf As String)
Dim Piece As Attachment
Dim REP_TOP As String
'-- On boucle sur les pièces jointes du message (si il y en a)
For j = 1 To myItem.Attachments.Count
'-- Initialisation de l'objet Pièce Jointe
Set Piece = myItem.Attachments(j)
'-- Sauvegarde du fichier correspondant.
REP_TOP = EnregistrerUnFichier(0, "enregistrer", Piece.FileName, "I:\")
Piece.SaveAsFile REP_TOP
Next j
Set Piece = Nothing
End Sub |
Sauvegarde des pièces jointes d'un nouveau message
http://www.developpez.net/forums/d29...utlook-2000-a/
Répondre avec citation
Envoyé par sanfric
Je ne réponds pas aux questions techniques par MP 
Oliv'
Partager