XL 2010 Extraction pièces jointe selon critères

[perdinch]

Bonjour,
ce code est sensé extraire les pièces jointes d'un dossier outlook en fonction du numéro de département
le numéro de département est obtenu en fonction du nom de la pièce jointe qui commence toujours par un code postal suivi d'un nom exemple "95240_DUPONT.xls"
le département est donc 95 dans l'exemple
hélas cette procédure ne fonctionne pas au niveau du SELECT CASE je pense.
merci de votre aide


Dim x As Integer


Sub ExtrairePjXml(Item As Outlook.MailItem)
Dim Ol As New Outlook.Application
Dim Ns As Outlook.NameSpace
Dim Inbox As MAPIFolder

Set Ns = Ol.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)

Dim x As Integer
Dim y As Integer
Dim pceJointe As Outlook.Attachment
Dim nomPJ As Integer

If Not Item.Attachments.Count = 0 Then
For y = 1 To Item.Attachments.Count
Set pceJointe = Item.Attachments(y)


Select Case nomPJ
nomPJ = Left(pceJointe.FileName, 2)

MsgBox = nomPJ
Case Is = "95"
NomDoss = "U:\Extractions_GLO_DT_95\"
pceJointe.SaveAsFile NomDoss & "\" & pceJointe.FileName
End If

Case Is =" 93"
x = x + 1
NomDoss = "U:\Extractions_GLO_DT_93\"
pceJointe.SaveAsFile NomDoss & "\" & pceJointe.FileName
End If
'etc.....
End Select


Set pceJointe = Nothing
Next y
End If

Dim myDestFolder As Outlook.Folder

Set myInbox = Ns.GetDefaultFolder(olFolderInbox)

Item.Move myDestFolder
End Sub

 

[Lone-wolf]

Bonsoir perdinch

Essaie celui-ci

Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
Public x As Integer
'La boite de réception, la boite des éléments supprimés et tous leurs
'sous dossiers sont pris en compte.
Sub ExportePiecesJointes()
Dim Ol As New Outlook.Application
Dim Ns As Outlook.Namespace
Dim Dossier As Outlook.MAPIFolder

    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)

    SearchFolders Dossier
    x = 0
End Sub


Private Sub SearchFolders(ByVal fld As Outlook.MAPIFolder)
Dim y As Integer
Dim OLmail    'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
Dim chemin As String

    chemin = "C:\Users\" & Environ("Username") & "\Desktop\"

    For Each SousDossier In fld.Folders
        '.Item("Nom_Du_Dossier").Items
        If SousDossier.DefaultItemType = 0 Then
            For Each OLmail In SousDossier.Items
                If Not OLmail.Attachments.Count = 0 Then
                    For y = 1 To OLmail.Attachments.Count
                        Set pceJointe = OLmail.Attachments(y)
                        x = x + 1
                        pceJointe.SaveAsFile chemin & pceJointe
                        Set pceJointe = Nothing
                    Next y
                End If
            Next OLmail
        End If
        SearchFolders SousDossier
    Next SousDossier
End Sub

 

[perdinch]

Bonsoir,

Merci de votre réponse .je le teste et j vous ferai un retour.
Cordialement