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 145 146 147
| Sub script(Mail As MailItem)
MsgBox "Vous venez de recevoir un Mail de " & Mail.SenderName & vbCrLf & "Ayant pour sujet " & Mail.Subject
End Sub
Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
' ***olivier CATTEAU***
' 23 avril 2007
Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem
Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)
'MsgBox "nouveau message"
If MyMail.Attachments.Count > 0 Then
expediteur = MyMail.SenderEmailAddress
'on crée le répertoire où mettre les fichiers joints ##########################################################
'c:\temp\pj\ doit déjà exister !!!
Repertoire = "c:\temp\pj\" & expediteur & "\"
If Repertoire <> "" Then
If "" = Dir(Repertoire, vbDirectory) Then
MkDir Repertoire
End If
End If
'on traite les pj
Dim PJ, typeatt
For Each PJ In MyMail.Attachments
'vérification si c'est une PJ Embedded
If typeatt = "" Then
If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
MsgBox Repertoire & PJ.FileName & " existe !!"
'si existe copie vers le répertoire old
If "" = Dir(Repertoire & "old", vbDirectory) Then
MkDir Repertoire & "old"
End If
FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName
End If
PJ.SaveAsFile Repertoire & PJ.FileName
End If
Next PJ
'drapeau vert
MyMail.FlagIcon = olGreenFlagIcon
'Marque lu
MyMail.UnRead = False
MyMail.Save
'on déplace le mail vers un sous dossier outlook
Dim myDestFolder As Outlook.MAPIFolder
Set myDestFolder = MyMail.Parent.Folders("test")
MyMail.Move myDestFolder
End If
Set MyMail = Nothing
Set olNS = Nothing
Fin:
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Isembedded(ByVal strEntryID As String, attindex As Integer) As Variant
Dim oSession As MAPI.Session
' CDO objects
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment
' initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
' get the message created earlier
Set oMsg = oSession.GetMessage(strEntryID)
' set properties of the attached graphic that make
' it embedded and give it an ID for use in an image tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Isembedded = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function |
Partager