Discussion :

[alexhsh]

Bonjour, comme évoqué dans le titre de la discussion je souhaite dans outlook lorsque je reçois un mail le selectionner et executer une macro qui enregistre la PJ du mail selectionné et en guise de nom de fichier le contenu d'une cellule de mon classeur Excel nommé toto qui est déjà ouvert,
J'ai pensé à ce code mais je bloque, je suis débutant en vba et vous remercie d'avance de votre précieuse aide :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub EnregistrerlaPJ()
 
    Dim MonOutlook As Outlook.Application
    Dim Mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Dim Res As Long
    Dim appExcel As New Excel.Application    'Ouverture de l'Application Excel
    Dim wbExcel As Excel.Workbook    'Classeur Excel
    Dim wsExcel As Excel.Worksheet    'Feuille Excel
    Dim xlmacroBook As Excel.Workbook
    Dim NumDossierRapportAgent As String
 
 
    Set MonOutlook = Outlook.Application
    'Selectionne le mail concerné par la PJ que je veux enregistrer
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    Workbooks("U:\TOTO.xlsm").Open
    NumDossierRapportAgent = activewokbook.Range("A14")
 
    For Each LeMail In LesMails
 
            Dim pj As Attachment
            For Each pj In LeMail.Attachments
                        LeFichier = "C:\Users\aallaert\Desktop\" & NumDossierRapportAgent
                        pj.SaveAsFile (LeFichier)
 
                   DoEvents
 
            Next pj
 
    Next LeMail
    Set LesMails = Nothing
    MsgBox "Opération terminée"
End Sub

[Oliv-]

bonsoir,
Sur quoi bloques tu ? Mise à part que tu n'auras au final qu'un seul fichier (la dernière pj traitée )

[alexhsh]

Merci tout d'abord pour ton intervention, c'est la ligne workbooks (nomde fichier) . Open qui me revient en anomalie. A noter que ce classeur excel sera forcément ouvert avantque je lance la macro. Oui effectivement je ne vais exécuter la macro que sur 1 seul mail à la fois qui ne contient que 1 seule pj. Merci de ton aide

[Oliv-]

SAlut,

Si ton fichier excel est ouvert tu ^^eux mettre la macro ci-dessous dans ce dernier et la lancer à partir d'Excel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub EnregistrerlaPJ()
 
    Dim MonOutlook As Object
    Dim Mail As Object
    Dim LeMail As Object
    Dim Res As Long
 
    Dim wsExcel As Excel.Worksheet    'Feuille Excel
    Dim NumDossierRapportAgent As String
 
 
    Set MonOutlook = CreateObject("Outlook.Application")
    On Error Resume Next
    'Selectionne le mail concerné par la PJ que je veux enregistrer
    Set LeMail = MonOutlook.Activeinspector.currentItem
    If LeMail Is Nothing Then
        'on prend le premier mail selectionné
        Set LeMail = MonOutlook.ActiveExplorer.Selection(1)
 
    End If
    On Error GoTo 0
 
    NumDossierRapportAgent = activewokbook.Range("A14")
 
    Dim pj As Attachment
    For Each pj In LeMail.Attachments
        LeFichier = "C:\Users\aallaert\Desktop\" & NumDossierRapportAgent
        pj.SaveAsFile (LeFichier)
 
        DoEvents
 
    Next pj
 
    MsgBox "Opération terminée"
End Sub

[alexhsh]

Merci de ton intervention et de ta suggestion, je suis effectivement passé par une procédure sous excel plutot que sous Outlook, j'ai aussi creusé pour gérer la signature d'Outlook, donc voilà pour ceux que ça interesse je laisse le code qui fonctionne sur mon PC :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub SendMail_TOTO()
  Dim OutApp As Object
  Dim OutMail As Object
  Dim sTmp As String, SigString As String
  Dim Signature As String
  Dim Strbody As String
  Dim Chemin As String
 
    Call enregistrerpjderniermail ' je fais appel ici à une fonction que je décrirai plus bas
 
    Fichier = ActiveWorkbook.Sheets("Feuil1").Range("A12").Value
    Chemin = "C:\Users\aa\Desktop\" & Fichier & " Rapport" & ".pdf"
 
 
    'If Dir(chemin) <> "" Then
 
 
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
 
 
  SigString = Environ("appdata") & "\Microsoft\Signatures\*.htm"
  If Dir(SigString) <> "" Then
    sTmp = Environ("appdata") & "\Microsoft\Signatures\" & Dir(SigString)
    Signature = GetBoiler(sTmp)
  Else
    Signature = ""
  End If
 
  With OutMail
    'Set body format to HTML
    .BodyFormat = olFormatHTML
    .To = "aa@aa.fr"
    .CC = ""
    .BCC = ""
    .Subject = "Exemple de sujet"
    .Attachments.Add Chemin
    .HTMLBody = "<span style=""color: black; background-color: "";""font-family: Tahoma; font-size: 16; text-decoration: overline underline ""><b>Range("A2") & "</span></SPAN> </b><Br>"  _ 
    & "<span style=""color: black; background-color: "";""font-family: Tahoma; font-size: 16; text-decoration: overline underline ""><b>Range("B1") & Range("F4") & Range("F1") & "</span></SPAN> </b><Br>" _
    & "<br>" _
    & "<span style=""color: black; background-color: "";""font-family: Tahoma; font-size: 16; text-decoration: overline underline "">Messieurs," & "</span></SPAN> </b><Br>" _
    & "Ci-joint le rapport.<br>" _
    & "<br>" _
    & "Vous souhaitant bonne réception,<br>" _
    & "Cordialement.<br>" _
    & "<br>" _
'je fais ensuite appel à la fonction getboiler décrite un peu plus bas pour insérer la signature prédéfinie dans Outlook
    & GetBoiler("C:\Users\aa\AppData\Roaming\Microsoft\Signatures\Aa.htm") _
 
 
 
    .Display
  End With
 
End Sub
 
Sub enregistrerpjderniermail()
 Dim MonOutlook As Object, MonMail As Object
 Dim ImpDefaut As String
 Dim myItem As Outlook.MailItem
 Dim myAttachments As Outlook.Attachments
 
 Set MonOutlook = CreateObject("Outlook.Application")
        With MonOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 'olFolderSentMail pour Messages envoyés olFolderInbox pour boite de reception
        If .Items.Count > 0 Then Set MonMail = .Items(1)
        End With
        Set myAttachments = MonMail.Attachments
        myAttachments.Item(1).SaveAsFile ("C:\Users\aallaert\Desktop\" & ActiveSheet.Range("A14"))
 
 
 
 
End Sub
 
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Voilà voilà bon amusement à ceux qui creusent !