Discussion :

[maxou1983]

* Bonjour *

comme mon intitulé le dit je veux sauvegarder les pièces jointes sous le dossier du client sur notre serveur en cliquant simplement sur un icone dans la barre d'acces rapide.
je veux en profiter du meme coup pour créer une liste de contact global sur notre serveur.
si le conatct est pas creer la macro ouvre un formulaire et demande l'ajout des données manquante et utilise ceux si pour creer un dossier client.
merci d'avance

[Jean-Philippe André]

Bonjour,

sur quelle partie de ce que tu souhaites faire rencontres-tu présentement un problème ?

[maxou1983]

voici ou j'en suis
le code a vraiment besoin d'un gros ménage
mais il fonctionne en grande partie

le problème est la récupération du nom de l'envoyeur du mail

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
83
84
85
86
87
88
89
90
91
92
 
Sub Extract_Attachments_From_selection()
Dim olMail As MailItem
Dim olAtchs As Attachments
Dim olSelection As Selection
Dim iCount As Long, i As Long
Dim sFolderPath As String, sFilePath As String, sDeletedFiles As String
Dim objWSCript As Object '//Shell Scripting
Dim olItems As Outlook.MailItem
Dim olName As Outlook.MailItem
Dim olNs As Outlook.NameSpace
Dim olTaskFolder As Outlook.MAPIFolder
Dim olTask As Outlook.TaskItem
Dim oPath As String
 
On Error Resume Next
'// Initial Shell Scriptit Instance
Set objWSCript = CreateObject("WScript.Shell")
Set olNs = GetNamespace("Mapi")
Set olTaskFolder = olNs.GetDefaultFolder(olFolderInbox)
Set olItems = olTaskFolder.Items
Set olName = olItems.Sender
 
 
 
'// Get My Document folder Path
sFolderPath = objWSCript.SpecialFolders(16)
 
 
 
 
'// Get the Selection
Set olSelection = ActiveExplorer.Selection
 
'// Set Where the attachements will be saved
oPath = sFolderPath & "\" & "Outlook Attachments" & "\" & olName & "\"
 
If Dir(oPath, vbDirectory) = 0 Then
    MkDir path:=oPath
End If
 
'______________________________________________________
'               Extract Attachments
'______________________________________________________
'// Looping all the mail items from selection
For Each olMail In olSelection
 
    Set olAtchs = olMail.Attachments
    iCount = olAtchs.Count '//Attachement count on mail item
    sDeletedFiles = ""
 
    '//If there are attachments
    If iCount > 0 Then
        For i = iCount To 1 Step -1
            sFilePath = oPath & olAtchs.Item(i).FileName
 
            olAtchs.Item(i).SaveAsFile sFilePath
 
            '// Optional: To delete the attachments
            'olatchs.Item(i).delete
 
            '// Modify mail body with note indicating where the attachments are saved
            If olMail.BodyFormat <> olFormatHTML Then
                sDeletedFiles = sDeletedFiles & vbNewLine & "<file://" & sFilePath & ">"
            Else
                sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & _
                                sFilePath & "'>" & sFilePath & "</a>"
            End If
 
        Next i
 
 
        If olMail.BodyFormat <> olFormatHTML Then
            olMail.Body = vbNewLine & "The file(s) were saved to " & sDeletedFiles & vbNewLine
        Else
            olMail.HTMLBody = "<p>" & "the file(s) were saved to " & sDeletedFiles & "</p>" & olMail.HTMLBody
        End If
 
        olMail.save
 
    End If
 
 
Next olMail
 
 
 
Door:
Set objWSCript = Nothing
Set olAtchs = Nothing
Set olSelection = Nothing
End Sub

[Jean-Philippe André]

Salut

Code :

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

olMail.SenderEmailAddress

ou

Code :

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

olMail.SenderName

[maxou1983]

Code :

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

olMail.SenderName

[/QUOTE]

j'ai une erreur de compil

[maxou1983]

je vous avise que je faire évoluer ce code énormément

[Oliv-]

je vous avise que je faire évoluer ce code énormément

Bonjour,
Je ne comprend pas trop ta remarque, mais tu trouveras ici un exemple de fonction

https://www.developpez.net/forums/bl...yperlien-mail/

ci-dessous la fonction pour retrouver l'expéditeur :

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
Private Function Get_sender_SMTP(Oitem As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = Oitem.Sender.GetExchangeUser
 
    Get_sender_SMTP = oEU.PrimarySmtpAddress
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = GetFromFromHeader(Oitem)
 
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = Oitem.SenderEmailAddress
End Function
 
Function GetFromFromHeader(objMail As Outlook.MailItem) As String
'---------------------------------------------------------------------------------------
' Procedure : GetToFromHeader
' Author    : OLIV- from original code brettdj
' Date      : 04/06/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objRegex As Object
    Dim objRegM As Object
    Dim MailHeader As String
    Dim ExtractText As String
    Dim i
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
    MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
 
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .ignorecase = True
        .Pattern = "(\n)From:.*<(.+)>"
        If .test(MailHeader) Then
            Set objRegM = .Execute(MailHeader)
            For i = 0 To objRegM(0).submatches.Count - 1
            If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then
            GetFromFromHeader = objRegM(0).submatches(i)
            Exit For
            End If
            Next i
        Else
            GetFromFromHeader = ""
        End If
    End With
End Function

[maxou1983]

Bonjour,
Je ne comprend pas trop ta remarque, mais tu trouveras ici un exemple de fonction

je te l'accorde ma remarque n'était pas clair
ce bout de code est un commencement pour un systeme de gestion de dessin.
et il me fera plaisir d'allimenter cette discution avec la suite du projets
j'ai déja certain code pour autodesk inventor, excel et access le tout va fonctioner ensemble
et il me fera plaisir de publié le tout pour ceux qui comme moi ne sont pas pro en programation.
avec ce systeme jestime une économie de temp de 90% dans certain cas et réduire les erreurs au minimum même pratiquement nul.

merci oliv ca semble être ce que je recherche j'essai ca.