slt out le monde
j ai un problème avec outlook 2007 (je suis sur xp)
j ai copier un code en vba dans Outlook pour enregistrer les pièce jointe automatique sans aucune intervention
Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
' ***moez ben mansour***
' 28/09/2010
Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem
Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)
If MyMail.Attachments.Count > 0 Then
expediteur = MyMail.SenderEmailAddress
Repertoire = "c:\x"
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
typeatt = Isembedded(strID, PJ.Index)
If typeatt = "" Then
If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
'si existe copie vers le répertoire old
If "" = Dir(Repertoire & "ancien commande promod", vbDirectory) Then
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
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
Set oMsg = oSession.GetMessage(strEntryID)
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
tous sa passe bien les pj s enregistre dans c:\x mais si je modifier ce répertoire avec un autre sur le réseau par exemple \\serveur\x une erreur se déclenche erreur 52 nom et num de fichier incorrecte et le problème sur ce ligne: If "" = Dir(Repertoire, vbDirectory) Then
ce problème de déclenche que si je met un chemin sur le réseau (hors de mon disq) et je men suis sur que le chemin du réseau et correcte et sa passe pas.
j'ai pas 2007, a corriger, donc (J'ai aucune trace de Fields, pour le test IsEmbedded), mais :
Option Explicit
Public Declare Function MkDir Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal DirPath As String) As Long
Public Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Public Const INVALID_FILE_ATTRIBUTES As Long = &HFFFFFFFF
Public Function DoesExist(ByRef vsPath As String) As Boolean
DoesExist = (GetFileAttributes(vsPath) <> INVALID_FILE_ATTRIBUTES)
End Function
Public Function extrait_PJ_vers_rep(ByVal Folder As String, ByRef Mail As Outlook.MailItem) As Long
Dim Attachment As Attachment
Dim IsEmbedded As Boolean
If Not Nothing Is Mail Then
If Mail.Attachments.Count > 0 Then
If Right$(Folder, 1) <> "" Then
Folder = Folder & ""
End If
For Each Attachment In Mail.Attachments
IsEmbedded = True
On Local Error Resume Next
'# Semble etre propre à Outlook 2007 et supérieur
IsEmbedded = Attachment.Fields(&H3712001E)
On Local Error GoTo 0
If IsEmbedded Then
If DoesExist(Folder & Attachment.FileName) Then
MkDir Folder & "ancien commande promod"
FileCopy Folder & Attachment.FileName, Folder & "ancien commande promod" & Attachment.FileName
Else
MkDir Folder
End If
Attachment.SaveAsFile Folder & Attachment.FileName
extrait_PJ_vers_rep = extrait_PJ_vers_rep + 1
End If
Next
'# Semble etre propre à Outlook 2007 et supérieur
'Mail.FlagIcon = olGreenFlagIcon
Mail.UnRead = False
Mail.Save
End If
DoEvents
End If
End Function
Sub test()
Dim Item As Object
Dim nAttachments As Long
Dim nCount As Long
Dim nMails As Long
Dim nMailsWithAttachments As Long
For Each Item In Session.GetDefaultFolder(olFolderInbox).Items
If TypeOf Item Is MailItem Then
nMails = nMails + 1
nCount = extrait_PJ_vers_rep("C:\x", Item)
If nCount Then
nMailsWithAttachments = nMailsWithAttachments + 1
nAttachments = nAttachments + nCount
End If
End If
Next
MsgBox nMails & " mails lus." & vbNewLine & _
nAttachments & " pièces jointes archivées, réparties dans " & nMailsWithAttachments & " mails.", vbInformation
End Sub
je vous merci pour votre solution
mais malheureusement la fonction DoesExit()engendre aussi des erreur
peut tu svp modifier les ligne de mon code (puisque mon code et lier avec des règles) pour que les pj s enregistre dans le répertoire \\serveur\x
et je vous remercie bien
aussi y a t'il une solution d extraire des pj d un mail et l'envoie automatiquement a son destinataire exp
un message qui comporte x.txt et y.txt y a t'il une possibilité d extraire juste y.txt et l'envoie automatiquement a sa destinataire (code vba par exemple avec règle)
et merci d avance.
slt renfield
je vous remerci encore
mon code est intègres dans un module et il s exécute a travers une règle sur Outlook pour cela je veut svp rectifier la ou les ligne pour qui il permet d enregistrer le pièce jointe voici le code Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem
Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)
If MyMail.Attachments.Count > 0 Then
expediteur = MyMail.SenderEmailAddress
Repertoire = "E:\x"
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
typeatt = Isembedded(strID, PJ.Index)
If typeatt = "" Then
PJ.SaveAsFile Repertoire & PJ.FileName
End If
Next PJ
MyMail.FlagIcon = olGreenFlagIcon
MyMail.UnRead = False
MyMail.Save
End If
Set MyMail = Nothing
Set olNS = Nothing
Fin:
End Sub
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
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
Set oMsg = oSession.GetMessage(strEntryID)
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
sur ce code ou je peut faire le mise a jour sur ce code et merci d avance
merci encore une Foix
j ai modifier votre code et il marche très bien mais lorsque je veut le sélectionner comme un script dans une règle "exécuter un script" la petite dialogue n affiche rien.
ce code doit s' exécuter que lorsque je reçois un message avec un nom d objet bien définie exemple "commande" donc il faut l' intégré "code" dans une règle le seul moyen c est l'exécuter comme un script dans Outlook 2007
s il y'a une autre méthode je vous remercie "en prenant compte juste des messages qui comprennent "commande "comme objet et pas les autres messages.
et svp je suis un débutant si vous voulez s il ya une solution avec précision
merci infiniment
