vba code verwijzen naar andere mailbox

[enrico85]

Beste Mensen,

Voor het automatisch opslaan van de bijlages in een bepaalde map heb ik onderstaande code gekregen:

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro. This code requires a reference to be set
' to the Microsoft Outlook 8.0 Object Model
    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim appOl As New Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim Atmt As Outlook.Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As Variant
    Set ns = appOl.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("test") ' Enter correct subfolder name.
    i = 0
' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
            If Right(Atmt.FileName, 3) = "pdf" Then
            ' This path must exist! Change folder name as necessary.
                FileName = "H:\Attachments\" & _
                    Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item
' Show summary message
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the C:\Email Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?" _
        , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then
            Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Set appOl = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: SaveAttachmentsToFolder" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

Met deze code lijkt die alleen de subfolder "test" te zoeken in mijn persoonlijke inbox. Ik beheer ook 4 andere inboxen en wil eigenlijk dat die ook hierin gaat zoeken naar een subfolder "test". Weet iemand wat ik dan moet aanpassen in bovenstaande code?

Hopelijk kunnen jullie mij verder helpen..

groet
enrico

 

[edmoor]

Je kan dezelfde NameSpace (ns) gebruiken en andere folders gebruiken. Bijvoorbeeld:
ns.Folders("FolderA").Folders("FolderAsub1").Folders("FolderAsub1sub2")

 

[enrico85]

Je kan dezelfde NameSpace (ns) gebruiken en andere folders gebruiken. Bijvoorbeeld:
ns.Folders("FolderA").Folders("FolderAsub1").Folders("FolderAsub1sub2")

Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = ns.Folders("test")

Deze werkt helaas ook niet. Misschien dat ik het verkeerd aan pas. Ben zelf niet echt thuis in VBA.

 

[enrico85]

Heeft iemand een oplossing voor mij?

groet
enrico

 

[pixcel]

Onderstaande procedure SaveAllAttachments doorloopt alle hoofdfolders en doet per folder een call naar jouw procedure, die zo is aangepast dat hij als input de folder accepteert. Verder geen wijzigingen.
Deze code compileert foutloos maar is niet getest. Maak backups voordat je het test!
Ik neem aan dat je dit uitvoert vanuit outlook, de getobjects zijn vervangen door Application.

Option Explicit

Public Sub SaveAllAttachments()
    
    Dim oFolder As Outlook.MAPIFolder

    For Each oFolder In Application.GetNamespace("MAPI").Folders
        Debug.Print oFolder.Name
        SaveAttachmentsToFolder oFolder
    Next
    
End Sub




Private Sub SaveAttachmentsToFolder(ByRef oFolder As Outlook.MAPIFolder)

    ' This Outlook macro checks a named subfolder in the Outlook Inbox
    ' (here the "Sales Reports" folder) for messages with attached
    ' files of a specific type (here file with an "xls" extension)
    ' and saves them to disk. Saved files are timestamped. The user
    ' can choose to view the saved files in Windows Explorer.
    ' NOTE: make sure the specified subfolder and save folder exist
    ' before running the macro. This code requires a reference to be set
    ' to the Microsoft Outlook 8.0 Object Model
    
    On Error GoTo SaveAttachmentsToFolder_err
    
    ' Declare variables
    Dim SubFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim Atmt As Outlook.Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As Variant
    
    Set SubFolder = oFolder.Folders("test")    ' Enter correct subfolder name.
    i = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
    ' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            ' Check filename of each attachment and save if it has "xls" extension
            If Right(Atmt.FileName, 3) = "pdf" Then
                ' This path must exist! Change folder name as necessary.
                FileName = "H:\Attachments\" & _
                           Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item
    ' Show summary message
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
                             & vbCrLf & "I have saved them into the C:\Email Attachments folder." _
                             & vbCrLf & vbCrLf & "Would you like to view the files now?" _
                             , vbQuestion + vbYesNo, "Finished!")
        ' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then
            Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
    ' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Exit Sub
    ' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
           & vbCrLf & "Please note and report the following information." _
           & vbCrLf & "Macro Name: SaveAttachmentsToFolder" _
           & vbCrLf & "Error Number: " & Err.Number _
           & vbCrLf & "Error Description: " & Err.Description _
           , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
    Resume
End Sub

 

[enrico85]

Helaas werkt het niet.

Hij geeft nu aan dat die een object niet kan vinden..

 

[enrico85]

Weet iemand wat ik moet aanpassen in de code zodat die gaat zoeken naar de submap 'test' in de gezamelijk inbox 'crediteuren' en niet alleen in mijn persoonlijk inbox?

groeten
enrico

 

[pixcel]

Je vraag staat op opgelost dus daar kijkt niemand meer naar.
Eerst zeg je dat het niet werkt, dan vraag je wat aangepast moet worden. Wat heb je nu aan code?

 

[snb]

Public Sub M_snb()
    For Each it In CreateObject("outlook.application").GetNamespace("MAPI").Folders
        Debug.Print it.Name
        c00 = it.Name
        For Each it1 In it.Folders
            Debug.Print it1.Name
            c00 = c00 & vbLf & it1.Name
            For Each it2 In it1.Folders
                Debug.Print it2.Name
                c00 = c00 & vbLf & it1.Name
                For Each it3 In it2.Folders
                    Debug.Print it3.Name
                    c00 = c00 & vbLf & it1.Name
                Next
            Next
        Next
    Next
    
    MsgBox c00
End Sub

 

[enrico85]

Nu heb ik eerst de code van snb

Public Sub M_snb()
    For Each it In CreateObject("outlook.application").GetNamespace("MAPI").Folders
        Debug.Print it.Name
        c00 = it.Name
        For Each it1 In it.Folders
            Debug.Print it1.Name
            c00 = c00 & vbLf & it1.Name
            For Each it2 In it1.Folders
                Debug.Print it2.Name
                c00 = c00 & vbLf & it1.Name
                For Each it3 In it2.Folders
                    Debug.Print it3.Name
                    c00 = c00 & vbLf & it1.Name
                Next
            Next
        Next
    Next
    
    MsgBox c00
End Sub

Daarna de code die ik al had.

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("facturen van-hoeckel") ' Enter correct subfolder name.
    i = 0
' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
            If Right(Atmt.FileName, 3) = "pdf" Then
            ' This path must exist! Change folder name as necessary.
                FileName = "H:\Attachments\" & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item
' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the H:\Attachments" _
        & vbCrLf & vbCrLf & "Have a nice day!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

Ik krijg dan de melding dat die een object niet kan vinden. Dit zal dan de mapnaam weer zijn. Terwijl die de map wel vind met de eerste code.
Hij vind overigens alleen de eerste gedeelde inbox die andere lijkt die niet te vinden.

Iemand een idee?