Soyez le premier à donner votre avis sur cette source.
Snippet vu 4 629 fois - Téléchargée 20 fois
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
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.