1. Accueil
  2. Tous les snippets
  3. Snippets Visual Basic / VB.NET
  4. Règle automatique d'extraction de fichiers joints

Règle automatique d'extraction de fichiers joints

Soyez le premier à donner votre avis sur cette source.

Snippet vu 4 629 fois - Téléchargée 20 fois

Commenter

Contenu du snippet

Créer une règle automatique pour extraire les pièces jointes avec le critère de l'adresse email de l'expéditeur, lorsqu'un nouvel email arrive dans l'inbox.
Si un fichier du même nom existe déjà, le nouveau fichier est renommé avec l'ajout de nom_du_fichier(x).ext

ATTENTION : fonctionne aussi lors d'un glisse-déposer dans l'inbox

Pour que cela fonctionne, copier-coller le code dans Project > Microsoft Outlook Objects > ThisOutlookSession
Sauvegarder, puis redémarrer Outlook.

Il suffit de changer ensuite le critère "xav.bourdeau@free.fr" par l'adresse de votre choix.

ATTENTION : Outlook doit accepter les macro VBA
Centre de gestion de la confidentialité > Paramètres des Macros > Notifications pour toutes les macros.

Et un p'tit merci ça motive à faire d'autres source.

Source / Exemple :

Public WithEvents myOlItems As Outlook.Items


Public Sub Application_Startup()

   ' Reference the items in the Inbox. Because myOlItems is declared
   ' "WithEvents" the ItemAdd event will fire below.
   Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items

End Sub


Public Sub myOlItems_ItemAdd(ByVal Item As Object)
    
    
    Dim myEmail, thisAttachment As Object
    Dim Att_Path As String
    Dim FileNameLegal As String
    Dim FinalNameCount As Integer
    
        
    If TypeName(Item) = "MailItem" And Item.Sender.Address = "xav.bourdeau@free.fr" Then
    'Check if the Item is a mail, and if the sender is the one we expect

        Att_Path = "C:\OutlookSave\"
        
    
        
        
        
        For i = 1 To Item.Attachments.Count
            Set thisAttachment = Item.Attachments.Item(i)
            FinalNameCount = 0
            FileNameLegal = LegalizeFileName(thisAttachment.DisplayName) 'removing unwanted chars, usefull for email attached
            FinalName = FileNameLegal
            While FileOrFolderExists(Att_Path & FinalName) = True 'if file already exist, a number will be implemente between filename & extenstion like filname(23).txt
                FinalNameCount = FinalNameCount + 1 'FinalNameCount is the index used to get unique name
                FinalName = FileNumbering(FileNameLegal, FinalNameCount) 'this function implement the number between filename & extenstion
            Wend
            thisAttachment.SaveAsFile Att_Path & FinalName
        Next
    
    End If
End Sub

Private Function FileNumbering(NomFichier As String, NumFichier As Integer) As String
    Dim DotPos As Integer
    If InStr(1, NomFichier, ".") = 0 Then 'if not "." exist, it means, not extension
        FileNumbering = NomFichier & "(" & NumFichier & ")"
    Else
    While Left(Right(NomFichier, DotPos), 1) <> "." 'find the first "." from the right, which is supposed to be the start of the extension
        DotPos = DotPos + 1
    Wend
    FileNumbering = Left(NomFichier, Len(NomFichier) - DotPos) & "(" & NumFichier & ")." & Right(NomFichier, DotPos - 1)
End If

End Function

Public Function FileOrFolderExists(FullPathFile As String) As Boolean
    'This function return TRUE if the file or folder exists, and return FALSE if it does not exist
    On Error GoTo argh 'ok ok, it's not beautifull, but work so fine, because DIR function has a lot of limitations, onerror manage all the others
    If Not Dir(FullPathFile, vbDirectory) = vbNullString Then FileOrFolderExists = True
    Exit Function
argh:
    FileOrFolderExists = False
    On Error GoTo 0
End Function

Function LegalizeFileName(FileName As String) As String
    'This function remove all windows files unwanted chars
    'Feel free to add any windows files forbidden characteres
    FileName = Replace(FileName, "\", "")
    FileName = Replace(FileName, "/", "")
    FileName = Replace(FileName, ":", "")
    FileName = Replace(FileName, "?", "")
    FileName = Replace(FileName, """", "")
    FileName = Replace(FileName, "<", "")
    FileName = Replace(FileName, ">", "")
    FileName = Replace(FileName, "|", "")
    LegalizeFileName = FileName
End Function

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (MoiLafouine)