Outlook attachements cleaner / extractor

Soyez le premier à donner votre avis sur cette source.

Vue 7 996 fois - Téléchargée 406 fois

Télécharger le projet

Commenter

Description

Programme permettant de sauvegarder toutes les pièces jointes d'un répertoire (et/ou de tous ses sous-répertoires) avec des critères sur les pièces jointes ou les expéditeurs etc...
Un rapport en HTML est généré à la fin, ce dernier est très facilement exportable sous excel (copier-coller)

Attention, 3 controls doivent être ajoutés

Microsoft Date and Time Picker Control 6.0
Microsoft ProgressBar Control 6.0
Microsoft TreeView Control 6.0

Vous trouver l'objet manquant à cette adresse

http://support.microsoft.com/kb/297381

Dans le zip, vous avez ces 2 fichiers

Save_Attachement.frm
Save_Attachement.frx

Et n'oubliez par le petit Merci.basic qui fait toujours plaisir

Source / Exemple :

'####################################################################
'# Author : Xavier Bourdeau (xav.bourdeau@free.fr                   #
'# Program : Attachement Saver       Version : 4.5.2                #
'#                                                                  #
'# This VBA Macros will extract attachements from an outlook folder #
'# (or recursive, since Version 3) & with criteria selection        #
'# Please share it, but don't modifiy it without notifying me and   #
'# sending me the new version.                                      #
'#                                                                  #
'# Thanks to David A.     for idea and inspiration                  #
'#                                                                  #
'####################################################################

'You'll need those additional controls
'if you are missing one of them, you will need MSCOMCT2.OCX in C:\Windows\System32 folder
'You can download MSCOMCT2.OCX at http://support.microsoft.com/kb/297381
'
'Microsoft Date and Time Picker Control 6.0
'Microsoft ProgressBar Control 6.0
'Microsoft TreeView Control 6.0
'
'You may need to restart Outlook when controls are just added
'


Public ProgressBarWidth As Integer

Private Sub Bt_About_Click()
    'Please do not edit this line, for the glory of I
    MsgBox "Attachement Saver" & vbCrLf & "This program is provided by Xavier Bourdeau" & vbCrLf & "Please send me bugs, comment and donation :o)", vbInformation, "About this little program"
End Sub

Private Sub Bt_Cancel_Click()
    'Good bye
    Unload Me
End Sub

Private Sub Bt_Export_Click()
    Dim Temp As Variant
    Temp = BrowseForFolder
    If Temp = False Then Exit Sub
    TextBox_Dir = Temp
    
End Sub


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

Private Sub CB_FileType_Change()
    TB_FileType = ""
    If CB_FileType = "Office docs" Then TB_FileType = "*.xls;*.xlsx;*.doc;*.docx;*.pps;*.ppt;*.ppsx;*.pptx"
    If CB_FileType = "Excel" Then TB_FileType = "*.xls;*.xlsx"
    If CB_FileType = "Word" Then TB_FileType = "*.doc;*.docx"
    If CB_FileType = "PowerPoint" Then TB_FileType = "*.pps;*.ppt;*.ppsx;*.pptx"
    If CB_FileType = "PDF" Then TB_FileType = "*.pdf"
    If CB_FileType = "Pictures" Then TB_FileType = "*.jpg;*.jpeg;*.bmp;*.gif;*.png"
    If CB_FileType = "Text" Then TB_FileType = "*.txt;*.csv"
    If CB_FileType = "No Type" Then TB_FileType = "*[blank]"
    If CB_FileType = "Archives" Then TB_FileType = "*.zip;*.rar;*.arj;*.tar.gz;*.tgz;*.cpio"
End Sub

Private Sub CB_Send_Change()
    If CB_Send = "Between" Then
        Label_To.Visible = True
        Date_2.Visible = True
    Else
        Label_To.Visible = False
        Date_2.Visible = False
    End If
    Me.Repaint
End Sub



Private Sub Chk_Send_Click()
    If CB_Send.Text = "" Then CB_Send.ListIndex = 0
End Sub

Private Sub Chk_SenderToCC_Click()
    If CB_SenderToCC = "" Then CB_SenderToCC.ListIndex = 0
End Sub

Private Sub Chk_Subject_Click()
    If CB_Subject.Text = "" Then CB_Subject.ListIndex = 0
End Sub

Private Sub ChkSenderToCC_Click()
    If CB_SenderToCC.Text = "" Then CB_SenderToCC.ListIndex = 0
End Sub

Private Sub CommandButton1_Click()
    
    Dim SelItem As Integer
    Dim FolderName(200) As String
    Dim Outlook_Archive As String
    Dim Outlook_Path As String
    Dim i, j As Integer
    Dim Delete_Param As Integer
    
    
    
    If FileOrFolderExists(TextBox_Dir) = False Or TextBox_Dir = "" Then
        MsgBox ("Destination folder does not exist or not set correctly")
        Exit Sub
    End If
    
    'Just checking that Target Folder has a \ at the end, in case path is entered manually, otherwise WriteLine & file extration will crash
    If Right(TextBox_Dir, 1) <> "\" Then
        TextBox_Dir = TextBox_Dir & "\"
    End If
    
    If Opt_Nothing = True Then
        Delete_Param = 0
    End If
    If Opt_Del_Att.Value = True Then
        If MsgBox("Are you sure you want to delete the attachement, after the files are extraceted ???", vbOKCancel) = vbCancel Then Exit Sub
        Delete_Param = 1
    End If
    If Opt_Del_Mail.Value = True Then
        If MsgBox("Are you sure you want to delete the mail, after the files are extraceted ???", vbOKCancel) = vbCancel Then Exit Sub
        Delete_Param = 2
    End If
    
    
    If tvw.SelectedItem = "Outlook" Then
        MsgBox "Do not select Outlook"
        Exit Sub
    End If
    If tvw.SelectedItem.Parent.Index < 2 Then
        MsgBox "You must select a subfolder"
        Exit Sub
    End If
        
        
    If Check_Recur = True Then
        
        Att_Proc_Recur tvw, tvw.SelectedItem, TextBox_Dir, TextBox_LogFile, Delete_Param
        MsgBox ("Export Completed" & vbCrLf & "Destination : " & TextBox_Dir & vbCrLf & "Log file : " & TextBox_Dir & TextBox_LogFile & vbCrLf & "Recursive Mode : folders & subfolders")
    Else
        SelItem = tvw.SelectedItem.Index
        i = 1
        While SelItem <> 1
            FolderName(i) = tvw.Nodes.Item(SelItem)
            i = i + 1
            SelItem = tvw.Nodes(SelItem).Parent.Index
        Wend
    
        'Outlook root is Item (0)
        'Outlook archive is supposed to be the Item -1 (1)
        
        Outlook_Archive = FolderName(i - 1)
        Outlook_Path = ""
        'Other Folder & Subfoler are item - x (x > 1)
        For j = i - 2 To 1 Step -1
            Outlook_Path = Outlook_Path & FolderName(j) & "/"
        Next
        Outlook_Path = Left(Outlook_Path, Len(Outlook_Path) - 1) 'remove the last "\" or it will confuse the Split function in Att_Proc
        
        'MsgBox (Outlook_Archive & vbCrLf & Outlook_Path & vbCrLf & TextBox_Dir & vbCrLf & TextBox_LogFile & vbCrLf & Delete_Param)
        Att_Proc Outlook_Archive, Outlook_Path, TextBox_Dir, TextBox_LogFile, Delete_Param
        MsgBox ("Export Completed" & vbCrLf & "Destination : " & TextBox_Dir & vbCrLf & "Log file : " & TextBox_Dir & TextBox_LogFile)
    End If
    
    
End Sub
    
Private Sub Att_Proc(Outlook_Archive As String, Outlook_Path As String, Att_Path As String, Att_Log As String, Delete_Param As Integer)
    Dim FinalName, FileNameLegal As String
    Dim FinalNameCount As Integer
    Dim Cpt As Integer
    Dim i, j As Integer
    Dim ProgressNum, PercentNum, PercentCount As Variant
    Dim MyFolders, MyFolder As Variant
    Dim FirstFileHeader As Boolean
    
    Dim objSubject As String
    Dim objSenderName As String
    Dim objTo As String
    Dim objCC As String
    Dim objReceivedTime As Date
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objFolder = objOutlook.GetNamespace("MAPI").Folders(Outlook_Archive)
    
    MyFolders = Split(Outlook_Path, "/", -1, 1)
    For Each MyFolder In MyFolders
        Set objFolder = objFolder.Folders(MyFolder)
    Next
    
    Cpt = 0 'Incremental number of attached files
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objLog = objFSO.CreateTextFile(Att_Path & Att_Log)
    
    
    objLog.WriteLine "<HTML><TITLE>Report of Saved Attachements</TITLE><BODY><table border=""1"" cellpadding=""5"" cellspacing=""5"" width=""100%""><tr><th>Date</th><th>Outlook Archive</th><th>Outlook Folders</th></tr><tr>"
    objLog.WriteLine "<td>" & Now & "</td><td>" & Outlook_Archive & "</td><td>" & Outlook_Path & "</td></tr></table><br>"
    
        
        
    Set objItems = objFolder.Items
    If objItems.Count = 0 Then
        objLog.WriteLine "<br><B>I did nothing : This outlook folder is empty</B><br>"
        Exit Sub
    End If
    
    'Set status line for those who like excel
    objLog.WriteLine "<table border=""1"" witdh=""100%"">" & _
                         "<tr>" & _
                            "<th>Sender</th>" & _
                            "<th>To</th>" & _
                            "<th>CC</th>" & _
                            "<th>Subject</th>" & _
                            "<th>Date</th>" & _
                            "<th>Attached File(s)</th>" & _
                         "</tr>"
        
    
    PercentCount = 0 'init value in case of restart
    ProgressBar.Min = 0
    ProgressBar.Max = objItems.Count
    ProgressBar.Value = 0
    PercentNum = 100 / objItems.Count
    
    For mailIndex = objItems.Count To 1 Step -1
        
        'in order to get percentage, PercentCount is the progression index for each mail
        'PercentLabel just add a % sign at the end
        ProgressBar.Value = ProgressBar.Value + 1
        PercentCount = PercentCount + PercentNum
        PercentLabel = Int(PercentCount) & "%" 'int avoid decimal and make the percentage beautiful
        Set objMailItem = objItems.Item(mailIndex)
        On Error Resume Next
        
        'those variables are used only to avoir any html crutial text write
        'because sometime to & cc crash for meeting invitation mail
        objTo = ""
        objCC = ""
        objSenderName = ""
        objSubject = objMailItem.Subject
        objReceivedTime = objMailItem.ReceivedTime
        objSenderName = objMailItem.SenderName
        objTo = objMailItem.To
        objCC = objMailItem.CC
        
        
        
        
        
        If objMailItem.Attachments.Count > 0 And _
            Subject_Match(objSubject) = True And _
            Date_Match(objReceivedTime) = True And _
            SenderToCC_Match(objSenderName, objTo, objCC) Then
            
            'Write log by mail with attachement
            'Properties possible
            '.Subject
            '.Attachments.Count
            '.UnRead
            '.SenderName
            '.ReceivedTime
            '.LastModificationTime
            '.ReplyRecipientNames
            '.SentOn
            '.Body

            
            On Error Resume Next
            
            FirstFileHeader = True
            
            For i = 1 To objMailItem.Attachments.Count
                
                Set pj = objMailItem.Attachments.Item(i)
                
                If FileSize_Match(pj.Size) = True _
                    And FileType_Match(pj.DisplayName) = True _
                    And FileName_Match(pj.DisplayName) = True Then
                
                    FinalNameCount = 0
                    FileNameLegal = LegalizeFileName(pj.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
                    pj.SaveAsFile Att_Path & FinalName 'Save the attached files
                    
                    Set pj = Nothing
                    If FirstFileHeader = True Then
                        objLog.WriteLine "<tr>" & _
                                  "<td>" & objMailItem.SenderName & "&nbsp;</td>" & _
                                  "<td>" & Replace(objTo, ";", "<br>") & "&nbsp;</td>" & _
                                  "<td>" & Replace(objCC, ";", "<br>") & "&nbsp;</td>" & _
                                  "<td>" & objSubject & "&nbsp;</td>" & _
                                  "<td>" & objMailItem.ReceivedTime & "</td>" & _
                                  "<td>" 'Start of file attached HTML part
                        FirstFileHeader = False
                    End If
                    objLog.WriteLine "<a target=""_blank"" href=""" & FinalName & """>" & FinalName & "</a><br>" ' Middle of file attached HTML part
                    Cpt = Cpt + 1
                End If
            Next
            objLog.WriteLine "</td></tr>" 'End of file attached HTML part
            
            If Delete_Param = 0 Then
                'do nothing ! Mouhahahahaha
            End If
            
            If Delete_Param = 1 Then
                While objMailItem.Attachments.Count > 0 'as the count decrement everytime a file is deleted, cannot use for, but use item(1), and repeat while count > 0
                    objMailItem.Attachments.Item(1).Delete 'delete the attached files
                Wend
                objMailItem.Save 'need to save the mail to apply the file(s) deletion
            End If
            
            If Delete_Param = 2 Then
                objMailItem.Delete 'The mail is delete. I kept this function as it was in the initial macro, but it's dangerous. There is two a warns about it
            End If
            
            If Not Err.Number = 0 Then
                objLog.WriteLine "<a target=""_blank"" href=""" & FinalName & """>" & FinalName & "</a> #ERROR<br>" ' Middle of file attached HTML part
            End If
            
        End If
    Next
    PercentLabel = "100%" 'force the 100%, otherwise, it ends at int(99.99999999999999999999) so 99% : that's not serious
    objLog.WriteLine "</tr></table><br><i>" & Cpt & " attachment(s) treated</i></BODY></HTML>"
    
    
    
End Sub

Private Sub Att_Proc_Recur(ByRef tv As TreeView, ByRef nodThis As Node, DestinationDir As String, LogFileName As String, Delete_Param As Integer)
      
      Dim lngIndex As Long
      Dim FolderName(200) As String
      Dim Outlook_Archive As String
      Dim Outlook_Path As String
      Dim Real_Path As String
      
      If nodThis.Children > 0 Then
        lngIndex = nodThis.Child.Index
        Call Att_Proc_Recur(tv, tv.Nodes(lngIndex), DestinationDir, LogFileName, Delete_Param)
        
        While lngIndex <> nodThis.Child.LastSibling.Index
          lngIndex = tv.Nodes(lngIndex).Next.Index
          Call Att_Proc_Recur(tv, tv.Nodes(lngIndex), DestinationDir, LogFileName, Delete_Param)
       Wend
     End If
      
      
     SelItem = nodThis.Index
        
     i = 1
     While SelItem <> 1
         FolderName(i) = tvw.Nodes.Item(SelItem)
         i = i + 1
         SelItem = tvw.Nodes(SelItem).Parent.Index
     Wend
    
    'Outlook root is Item (0)
    'Outlook archive is supposed to be the Item -1 (1)
    
    Outlook_Archive = FolderName(i - 1)
    Outlook_Path = ""
    'Other Folder & Subfoler are item - x (x > 1)
    For j = i - 2 To 1 Step -1
        Outlook_Path = Outlook_Path & FolderName(j) & "/"
    Next
    Outlook_Path = Left(Outlook_Path, Len(Outlook_Path) - 1) 'remove the last "\" or it will confuse the Split function in Att_Proc
    Real_Path = Replace(Outlook_Path, "/", "\") & "\" 'cheating... will pay for it one day
    
    
    CreateSubDirectories (DestinationDir & LegalizeFolderName(Real_Path))
    Att_Proc Outlook_Archive, Outlook_Path, DestinationDir & LegalizeFolderName(Real_Path), LogFileName, Delete_Param
    
    'MsgBox (nodThis.Index)

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

Private Sub Opt_Del_Att_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    
    If Opt_Del_Att = True Then
        If MsgBox("Are you sure you want to delete the attachement, after the files are extraceted ???", vbOKCancel, "WARNING") = vbCancel Then
            Opt_Del_Att = False
            Opt_Nothing = True
            Cancel = True
        End If
    End If
    
End Sub

Private Sub Opt_Del_Mail_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    
    If Opt_Del_Mail = True Then
        If MsgBox("Are you sure you want to delete the mail, after the files are extraceted ???", vbOKCancel, "WARNING") = vbCancel Then
            Opt_Del_Mail = False
            Opt_Nothing = True
            Cancel = True
        End If
    End If
    
End Sub


Private Sub UserForm_Initialize()
    
    PercentLabel = ""
    Dim olApp As Outlook.Application
    Dim olNameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim tvNode As MSComctlLib.Node
    Dim tvRoot As MSComctlLib.Node
    
    Set olApp = GetObject(, "Outlook.Application")
    Set tvRoot = tvw.Nodes.Add(Text:="Outlook")
    Set olNameSpace = olApp.GetNamespace("MAPI")
    
    GetSubFolders olNameSpace, tvRoot
    
    Set tvNode = Nothing
    Set olFolder = Nothing
    Set olNameSpace = Nothing
    Set tvRoot = Nothing
    Set olApp = Nothing
    
    'Addint Combo box criteria
    
    CB_Subject.AddItem "Contains"
    CB_Subject.AddItem "Is"
    CB_Subject.AddItem "Is not"
    CB_Subject.ListIndex = 0
    
    CB_Send.AddItem "After"
    CB_Send.AddItem "Before"
    CB_Send.AddItem "Between"
    CB_Send.AddItem "This day"
    CB_Send.ListIndex = 0
    
    CB_SenderToCC.AddItem "Contains"
    CB_SenderToCC.AddItem "Is"
    CB_SenderToCC.AddItem "Is not"
    CB_SenderToCC.ListIndex = 0
    
    Opt_Kb.Value = True
    
    CB_FileSize.AddItem "Bigger Than"
    CB_FileSize.AddItem "Smaller Than"
    CB_FileSize.ListIndex = 0
    
    CB_FileType.AddItem "Office docs"
    CB_FileType.AddItem "Excel"
    CB_FileType.AddItem "Word"
    CB_FileType.AddItem "PowerPoint"
    CB_FileType.AddItem "PDF"
    CB_FileType.AddItem "Pictures"
    CB_FileType.AddItem "Text"
    CB_FileType.AddItem "Archives"
    CB_FileType.AddItem "No Type"
    CB_FileType.ListIndex = 0
    
    CB_FileName.AddItem "Contains"
    CB_FileName.AddItem "Is"
    CB_FileName.ListIndex = 0
End Sub

Private Function FileType_Match(NomFichier As String) As Boolean
    Dim DotPos As Integer
    Dim myType As String
    Dim formType, thisType As Variant
    
    If Chk_FileType = False Then
        FileType_Match = True
        Exit Function
    End If
    FileType_Match = False
    
    If InStr(1, NomFichier, ".") = 0 Then 'if not "." exist, it means, not extension
        If InStr(1, TB_FileType, "*[blank]") > 0 Then
            FileType_Match = True
        Else
            FileType_Match = False
        End If
        Exit Function
    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
        myType = Right(NomFichier, DotPos - 1)
    End If
    
    formType = Split(TB_FileType, ";")
    For Each thisType In formType
        If InStr(1, thisType, myType) > 0 Then
            FileType_Match = True
        End If
    
    Next
    
End Function


Function FileSize_Match(myFileSize As Long) As Boolean
    Dim byteSize As Long
    
    If Chk_FileSize = False Or TB_FileSize = "" Then
        FileSize_Match = True
        Exit Function
    End If
        
    If Opt_Kb = True Then
        byteSize = Int(TB_FileSize) * 1024
    Else
        byteSize = Int(TB_FileSize) * 1024 * 1024
    End If
    
    FileSize_Match = False
    
    If CB_FileSize = "Bigger Than" Then
        If myFileSize >= byteSize Then FileSize_Match = True
    ElseIf cbfilesize = "Smaller Than" Then
        If myFileSize <= byteSize Then FileSize_Match = True
    End If
    
End Function

Function FileName_Match(myAttachement As String) As Boolean
    If Chk_FileName = False Then
        FileName_Match = True
        Exit Function
    End If
    FileName_Match = False
    
    If CB_FileName = "Is" And UCase(TB_FileName) = UCase(myAttachement) Then
        FileName_Match = True
    ElseIf CB_FileName = "Contains" And InStr(1, UCase(myAttachement), UCase(TB_FileName)) > 0 Then
        FileName_Match = True
    End If
    

End Function

Function Subject_Match(Mail_Subject As String) As Boolean
    If Chk_Subject = False Then
        Subject_Match = True
        Exit Function
    End If
    Subject_Match = False
    
    If CB_Subject = "Is" And UCase(TB_Subject) = UCase(Mail_Subject) Then
        Subject_Match = True
    ElseIf CB_Subject = "Is not" And UCase(TB_Subject) <> UCase(Mail_Subject) Then
        Subject_Match = True
    ElseIf CB_Subject = "Contains" And InStr(1, UCase(Mail_Subject), UCase(TB_Subject)) > 0 Then
        Subject_Match = True
    End If
    

End Function

Function SenderToCC_Match(Sender_Mail As String, To_Mail As String, CC_Mail As String) As Boolean
    If Chk_SenderToCC = False Then
        SenderToCC_Match = True
        Exit Function
    End If
    SenderToCC_Match = False
    
    If CB_SenderToCC = "Is" And (UCase(TB_SenderToCC) = UCase(Sender_Mail) _
                                Or UCase(TB_SenderToCC) = UCase(To_Mail) _
                                Or UCase(TB_SenderToCC) = UCase(CC_Mail)) Then
        SenderToCC_Match = True
    ElseIf CB_SenderToCC = "Is not" And (InStr(1, UCase(Sender_Mail), UCase(TB_SenderToCC)) = 0 _
                                    And InStr(1, UCase(To_Mail), UCase(TB_SenderToCC)) = 0 _
                                    And InStr(1, UCase(CC_Mail), UCase(TB_SenderToCC)) = 0) Then
        SenderToCC_Match = True
    ElseIf CB_SenderToCC = "Contains" And (InStr(1, UCase(Sender_Mail), UCase(TB_SenderToCC)) > 0 _
                                      Or InStr(1, UCase(To_Mail), UCase(TB_SenderToCC)) > 0 _
                                      Or InStr(1, UCase(CC_Mail), UCase(TB_SenderToCC)) > 0) Then
        SenderToCC_Match = True
    End If
    

End Function

Function Date_Match(Mail_Date As Date) As Boolean
    If Chk_Send = False Then
        Date_Match = True
        Exit Function
    End If
    Date_Match = False

    If CB_Send = "Before" And Mail_Date <= Date_1 Then
        Date_Match = True
    ElseIf CB_Send = "After" And Mail_Date >= Date_1 Then
        Date_Match = True
    ElseIf CB_Send = "Between" And Mail_Date >= Date_1 And Mail_Date <= Date_2 Then
        Date_Match = True
    ElseIf CB_Send = "This day" And Mail_Date = Date_1 Then
        Date_Match = True
    End If


End Function

Private Sub GetSubFolders(olFolder, tvNode As MSComctlLib.Node)
    Dim tvChild As MSComctlLib.Node
    Dim olSubFolder As Outlook.MAPIFolder
    
    For Each olSubFolder In olFolder.Folders
        Set tvChild = tvw.Nodes.Add(Text:=olSubFolder.Name, _
        Relative:=tvNode, Relationship:=tvwChild)
        GetSubFolders olSubFolder, tvChild
    Next olSubFolder
    
    Set olSubFolder = Nothing
    Set tvChild = Nothing
    
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    
    Dim ShellApp As Object
     
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
    Set ShellApp = Nothing
     
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":" 'My macro will never work on a MAC, but how cares
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
    BrowseForFolder = False 'shit happens
     
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

Function LegalizeFolderName(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, "\", "") --> for sure we need to keep the \ for the folders
    FileName = Replace(FileName, "/", "")
    FileName = Replace(FileName, ":", "")
    FileName = Replace(FileName, "?", "")
    FileName = Replace(FileName, """", "")
    FileName = Replace(FileName, "<", "")
    FileName = Replace(FileName, ">", "")
    FileName = Replace(FileName, "|", "")
    LegalizeFolderName = FileName
    



End Function

Sub CreateSubDirectories(fullPath As String)
 
    Dim str As String
    Dim strArray As Variant
    Dim i As Long
    Dim basePath As String
    Dim newPath As String
     
    str = fullPath
     
    ' add trailing slash
    If Right$(str, 1) <> "\" Then
     str = str & "\"
    End If
     
    ' split string into array
    strArray = Split(str, "\")
     
    basePath = strArray(0) & "\"
     
    ' loop through array and create progressively
    ' lower level folders
    For i = 1 To UBound(strArray) - 1
      If Len(newPath) = 0 Then
        newPath = basePath & newPath & strArray(i) & "\"
      Else
        newPath = newPath & strArray(i) & "\"
      End If
     
      If Not FileOrFolderExists(newPath) Then
        MkDir newPath
      End If
    Next i
 
End Sub

Télécharger le projet

Codes Sources

A voir également

Outlook temp cleaner
Ucase visual basic - Meilleures réponses
Outlook vb.net - Meilleures réponses
Outlook resiliency cleaner - Codes sources - C# / .NET (Applications)
Envoyer un fichier attaché avec outlook ✓ - Forum - Visual Basic 6
Access message à Outlook Express avec un fichier attaché ✓ - Forum - Visual Basic
Un programme tente d'envoyer un message électronique en votre nom outlook ✓ - Forum - Visual Basic 6
Extraire piece jointe outlook vba - Guide

Ajouter un commentaire

Commentaires

Signaler

coyotej2

Messages postés: 13
Date d'inscription: mercredi 22 février 2006
Statut: Membre
Dernière intervention: 20 mai 2013

15 oct. 2012 à 08:15

Bonjour.
Simple question : cela peut-il marcher aussi avec Outlook 2003 ?
Merci et en tout cas bravo pour ce partage de savoir faire.

Signaler

MoiLafouine

Messages postés: 1
Date d'inscription: mercredi 2 mars 2005
Statut: Membre
Dernière intervention: 16 février 2012

16 févr. 2012 à 18:52

Merci Loulou69 pour ton message de remerciement :o) Ma première vraie donation au monde du "libre".
Personnellement j'utilise les dossiers publics et personels, je n'ai donc pas enlevé ces dossiers.
Il est a noter que ce programme ne fonctionne pas hors-ligne, peut-être à cause de cela. Je n'ai pas encore creusé la question. (j'utilise Outlook 2010).
Si certains voulaient qu'il puisse fonctionner hors ligne, merci de m'envoyer vos commentaires !

Signaler

cs_loulou69

Messages postés: 672
Date d'inscription: mercredi 22 janvier 2003
Statut: Membre
Dernière intervention: 2 juin 2016

1
16 févr. 2012 à 11:19

merci Moilafouine,

ce programme est très utile.
je commence les tests, il a fallu que j'adapte la procédure pour filtrer le chargement et ne pas charger dans la treeview les "Dossiers personnels" et les "Dossiers publics" j'ai ajouté dans la fonction GetSubFolders un paramétre afin de ne pas descendre les dites arborescences. J'ai constaté le bon export des documents joints. Merci mille fois

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.

Outlook attachements cleaner / extractor

Description

Source / Exemple :

Codes Sources

A voir également

Commentaires

Vous n'êtes pas encore membre ?

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

Du même auteur (MoiLafouine)

Règle automatique d'extraction de fichiers joints

Source / Exemple :

A voir également

Vous n'êtes pas encore membre ? inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (MoiLafouine)

Règle automatique d'extraction de fichiers joints

Vous n'êtes pas encore membre ?

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