Bijlages opslaan van geselecteerd folder en subfolders in outlook

Status
Niet open voor verdere reacties.

AatB

Gebruiker
Lid geworden
15 dec 2007
Berichten
253
Goedemorgen,

Ik wil alle bijlages opslaan van een folder en zijn subfolders in Outlook.
Ben al een beetje op streek en het werkt voor een folder.
Alleen nu de subfolders nog..... wellicht dat mij iemand in de goede richting kan duwen ;)

Bedankt alvast,

Grt Aat

Code:
Public Sub SaveAttachments()
    
    Dim objOutLook As Outlook.Application
    Dim objSelection As Outlook.Selection
    Dim objMsg As Outlook.MailItem
    Dim objAttachment As Outlook.Attachment
    
    Dim YearFolder As String
    Dim TmpFolder As String
    Dim FldrName As String
    Dim SenderFolder As String
    Dim Map As String
    Dim Fname As String
    Dim Ext As String
    
    Dim dd As Date
    
    'Check if main folder exist ---------------------------------------------------
    TmpFolder = CreateObject("WScript.Shell").SpecialFolders(16) & "\ABBA" 'OneDrive\ABBA\
    Map = Dir(TmpFolder, vbDirectory)
    If Map = "" Then MkDir TmpFolder
    
    TmpFolder = TmpFolder & "\Bijlagen Outlook" 'OneDrive\ABBA\Bijlagen Outlook
    Map = Dir(TmpFolder, vbDirectory)
    If Map = "" Then MkDir TmpFolder
    '--------------------------------------------------------------------------
    
    Set objOutLook = CreateObject("Outlook.Application")
     
    ' Get the collection of selected objects ----------------------------------
    Set objSelection = objOutLook.ActiveExplorer.Selection
    
    ' Check for attachments and save them in the folder \Year\Sendername\ ------
    For Each objMsg In objSelection
        
        FldrName = objMsg.Sender
        
        'Check if YearFolder exist ------------------------------------------
        dd = Format(objMsg.ReceivedTime, "yyyy-mm-dd")
        YearFolder = TmpFolder & "\" & Year(dd)
        Map = Dir(YearFolder, vbDirectory)
        If Map = "" Then MkDir YearFolder
        
        'Check of senderfolder bestaat ------------------------------------------
        SenderFolder = YearFolder & "\" & FldrName
        Map = Dir(SenderFolder, vbDirectory)
        If Map = "" Then MkDir SenderFolder
        '----------------------------------------------------------------------
        
        For Each objAttachment In objMsg.Attachments
            Fname = objAttachment.DisplayName
            
            If InStrRev(Fname, ".") Then
                Ext = LCase(Mid(Fname, InStrRev(Fname, ".")))
                Select Case Ext
                    Case ".pdf", ".doc", ".docx", ".xls", ".xlsx", ".xlsm"
                        objAttachment.SaveAsFile SenderFolder & "\" & dd & " " & Fname
                End Select
            End If
        Next
    
    Next
    
    Set objOutLook = Nothing
    Set objSelection = Nothing
    Set objMsg = Nothing
    Set objAttachment = Nothing

End Sub
 
Je kunt de subfolders uitlezen met een recursieve functie. Iets als dit:

Code:
Function ProcessSubFolder(olkFolder As Outlook.MAPIFolder)
Dim olkSubFolder As Outlook.MAPIFolder
    Debug.Print olkFolder.FolderPath
    For Each olkSubFolder In olkFolder.Folders
        ProcessSubFolder olkSubFolder
    Next
End Function

Code:
Sub TestFolders()
Dim oInbox As Outlook.MAPIFolder

    Set oInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    ProcessSubFolder oInbox
End Sub

Kijk maar waar je je eigen code in kan zetten :).
 
Ja, en dat is wat ik u net zoek.... waar en wat zet ik bij mij in code....
Ik had zo iets al gevonden, maar ik kom er niet uit...
Ik wil starten vanuit de folder welke ik in outlook selecteer.

Code:
Set objSelection = objOutLook.ActiveExplorer.Selection
 
Gelukt.....kostte wat tijd en moeite....maar OctaFish heeft mij in ieder geval de goed kant opgestuurd. Bedankt.

Hieronder de code om alle bijlagen van een folder en zijn sub-folders binnen Outlook op te slaan.

Code:
Option Explicit
Sub SaveAttachments()
 
    Dim cFolder As Object
    
    Set cFolder = ActiveExplorer.CurrentFolder
    
    ProcessFolder cFolder
 
End Sub
Private Sub ProcessFolder(oParent As Object)
    
    Dim oAttachment As Outlook.Attachment
    Dim oMail As Outlook.MailItem
   
    Dim YearFolder As String
    Dim RootFolder As String
    Dim AttachmentFolder As String
    
    Dim Map As String
    Dim Fname As String
    Dim Ext As String
    
    Dim dd As Date
    
    '---------------------------------------------------------------------------------------------------------------
    ' Check if RootFolder exist
    '---------------------------------------------------------------------------------------------------------------
    RootFolder = CreateObject("WScript.Shell").SpecialFolders(16) & "\Bijlage Outlook" 'OneDrive\Bijlagen Outlook
    Map = Dir(RootFolder, vbDirectory)
    If Map = "" Then MkDir RootFolder
    '---------------------------------------------------------------------------------------------------------------
    
    '---------------------------------------------------------------------------------------------------------------
    ' Check for attachments and save them in the folder \Year\Sendername\
    '---------------------------------------------------------------------------------------------------------------
    For Each oMail In oParent.Items
          
        AttachmentFolder = VreemdeTekens(oMail.Sender)
        
        If InStr(AttachmentFolder, "@") Then
            AttachmentFolder = LCase(Left(AttachmentFolder, InStr(AttachmentFolder, "@") - 1))
            AttachmentFolder = Replace(AttachmentFolder, ".", " ")
            AttachmentFolder = Replace(AttachmentFolder, "_", " ")
        End If
        
        AttachmentFolder = WorksheetFunction.Proper(LCase(AttachmentFolder))
                
        '-----------------------------------------------------------------------------------------------------------
        ' Check if YearFolder exist
        '-----------------------------------------------------------------------------------------------------------
        dd = Format(oMail.ReceivedTime, "yyyy-mm-dd")
        YearFolder = RootFolder & "\" & Year(dd)
        Map = Dir(YearFolder, vbDirectory)
        If Map = "" Then MkDir YearFolder
        '-----------------------------------------------------------------------------------------------------------
        
        
        For Each oAttachment In oMail.Attachments
            Fname = oAttachment.DisplayName
            
            If InStrRev(Fname, ".") Then
                Ext = LCase(Mid(Fname, InStrRev(Fname, ".")))
                Select Case Ext
                    Case ".pdf", ".doc", ".docx", ".xls", ".xlsx", ".xlsm"
                    
                        '-------------------------------------------------------------------------------------------
                        ' Check if AttachmentFolder exist
                        '-------------------------------------------------------------------------------------------
                        AttachmentFolder = YearFolder & "\" & AttachmentFolder
                        Map = Dir(AttachmentFolder, vbDirectory)
                        If Map = "" Then MkDir AttachmentFolder
                        '-------------------------------------------------------------------------------------------
                        
                        oAttachment.SaveAsFile AttachmentFolder & "\" & dd & " " & Fname
                        AttachmentFolder = ""
                End Select
            End If
        Next
    
    Next
   
    Set oMail = Nothing
    Set oAttachment = Nothing

End Sub

Function VreemdeTekens(tmp)
    
    Dim x, k
    
    tmp = tmp & " "
    
    For k = 0 To 126
        Select Case k
            
            Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
            21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 33, 34, 35, 36, 37, 38, 40, 41, _
            39, 40, 41, 42, 43, 44, 45, 46, 47, 58, 59, 60, 61, 62, 63, _
            91, 93, 94, 95, 96, 123, 124, 125, 126, 127
                
            tmp = Replace(tmp, Chr(k), " ")
        
        End Select
    Next
    
    tmp = Replace(tmp, " '", " ")
    tmp = Replace(tmp, "' ", " ")
    
    While InStr(1, tmp, "  ")
        tmp = Replace(tmp, "  ", " ")
    Wend
    
    VreemdeTekens = Trim(tmp)

End Function
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan