VBA outlook: subfolders - undermapper - hvordan henviser man

Denne kode som er et eksempel fra en bog, det drejer sig dog om at fjerne vedhæftede filer, men også at gemme dem. Uden at være ekspert på vbscript, mener jeg at kunne se, at der er et stykke om undermapper.
Måske kan du bruge noget af koden.

'*************************************************************
'Custom Form: Remove Attachments
'Purpose: Remove attachments on messages in folder
'*************************************************************
'Script-level declarations
Dim cmdRemoveAttachments
Dim lblFolder
Dim lblStatus
Dim chkSub
Dim chkSave
Dim lngCount
Dim objFolder
Dim objCDOFolder
Dim gobjCDO
Dim strTempPath

Sub Item_Open
        On Error Resume Next
        Set lblFolder = GetInspector.ModifiedFormPages("Remove Attachments").Controls("lblFolder")
        Set lblStatus = GetInspector.ModifiedFormPages("Remove Attachments").Controls("lblStatus")
        Set chkSave = GetInspector.ModifiedFormPages("Remove Attachments").Controls("chkSave")
        Set chkSub = GetInspector.ModifiedFormPages("Remove Attachments").Controls("chkSub")
        Set cmdRemoveAttachments = GetInspector.ModifiedFormPages("Remove Attachments").Controls("cmdRemoveAttachments")

        Set gobjCDO = CreateObject("MAPI.Session")
        gobjCDO.Logon "", "", False, False
        If Err Then
                MsgBox "Could not logon to CDO Session.", vbCritical
                Exit Sub
        End If
        strTempPath = GetTempDir
End Sub

Sub cmdPickFolder_Click
        Dim objNS, avarArray
        On Error Resume Next
        Set objNS = Application.GetNamespace("MAPI")
        lblStatus.Caption = ""
        Set objFolder = objNS.PickFolder
        If objFolder Is Nothing Then
                Exit Sub
        Else
                lblFolder.Caption = GetFolderPath(objFolder)
                'Use Outlook EntryID and StoreID to get a CDO Folder
                Set objCDOFolder = gobjCDO.GetFolder(objFolder.EntryID,objFolder.StoreID)
                cmdRemoveAttachments.Enabled = True
        End If
End Sub

Sub cmdRemoveAttachments_Click
        Dim strMsg
        On Error Resume Next
        lngCount = 0
        strMsg = "Remove all attachments from items in " & vbCr & lblFolder
        If chkSub.Value = True Then
                strMsg = strMsg & vbCr & "and its subfolders?"
        Else
                strMsg = strMsg & "?"
        End If
        If chkSave.Value = True Then
                strMsg = strMsg & vbCr & vbCr & _
                  "Attachments will be saved into " & vbCr & strTempPath
        End If
        If MsgBox(strMsg, vbYesNo + vbQuestion)=vbYes Then
                If chkSub.Value = True Then 'Enumerate subfolders
                        EnumerateFolders(objCDOFolder)
                        lblStatus.Caption = "Processing Complete - " _
                          & "Removed " & lngCount & " Attachments"
                Else
                        RemoveAttachments(objCDOFolder)
                        lblStatus.Caption = "Processing Complete - " _
                          & "Removed " & lngCount & " Attachments"
                End If
        End If
End Sub

'*********************************************************************
'Custom procedure: EnumerateFolders(objParentFolder)
'Purpose: Recurse folders under parent folder
'Argument: CDO Folder object
'Usage:
'Returns:
'*********************************************************************
Function EnumerateFolders(objParentFolder)
        Dim colchildFolders
        Dim ChildFolder
        Set colchildFolders = objParentFolder.Folders
        If colchildFolders.Count <> 0 Then
                For Each ChildFolder In colchildFolders
                        RemoveAttachments ChildFolder
                        EnumerateFolders ChildFolder
                Next
        End If
End Function

'*********************************************************************
'Custom procedure: RemoveAttachments(objFolder)
'Purpose: Delete attachments from all items in folder
'Argument: CDO Folder object
'Usage:
'Returns:
'Note: This code will overwrite a saved attachment if another
'attachment with the same name already exists in the Attach folder
'It does not handle the creation of a separate unique name for
'duplicate attachment names.
'*********************************************************************
Function RemoveAttachments(objFolder)
        Dim i, objMsg, oAttach
        On Error Resume Next
        For i = 1 to objFolder.Messages.Count
                Set objMsg = objFolder.Messages.Item(i)
                If objMsg.Attachments.Count Then
                        lblStatus.Caption = "Processing " & objMsg.Subject
                        Do Until objMsg.Attachments.Count = 0
                                Set oAttach = objMsg.Attachments.Item(1)
                                If chkSave.Value Then
                                        If oAttach.Type = 1 Then 'cdoFileData
                                                oAttach.WriteToFile strTempPath & "\" & oAttach.Name
                                        End If
                                End If
                                oAttach.Delete
                                lngCount = lngCount + 1
                        Loop
                        objMsg.Update
                End If
        Next
End Function

'*********************************************************************
'Custom procedure: GetTempDir
'Purpose: Return a string path to the Attach folder under Temp
'Argument:
'Usage:
'Returns: String representing File system Path
'*********************************************************************
Function GetTempDir
        Const TemporaryFolder = 2, SystemFolder = 1, WindowsFolder = 0
        On Error Resume Next
        Dim fso, tfolder, tattach
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set tfolder = fso.GetSpecialFolder(TemporaryFolder)
        If fso.FolderExists(tFolder.Path & "\Attach") Then
                GetTempDir = lcase(tFolder.Path & "\Attach")
                Exit Function
        Else
                Set tattach = fso.CreateFolder(tFolder.Path & "\Attach")
                GetTempDir = lcase(tAttach.Path)
        End If
End Function

'*********************************************************************
'Custom procedure: GetFolderPath(ByVal objFolder)
'Purpose: Return a string folder path for a MAPIFolder
'Argument: MAPIFolder object
'Usage: MsgBox "The Folder Path is " & GetFolderPath(objFldr)
'Returns: String representing Folder Path
'*********************************************************************
Function GetFolderPath(ByVal objFolder) 'As String
        On Error Resume Next
        Dim strFolderPath 'As String
        Dim objChild 'As MAPIFolder
        Dim objParent 'As MAPIFolder
        strFolderPath = "\" & objFolder.Name
        Set objChild = objFolder
        Do Until Err <> 0
                Set objParent = objChild.Parent
                If Err <> 0 Then
                        Exit Do
                End If
                strFolderPath = "\" & objParent.Name & strFolderPath
                Set objChild = objParent
        Loop
        GetFolderPath = strFolderPath
End Function

Sub imgShowScript_Click
        Set objForm = Item.FormDescription
        Set objMsg = Application.CreateItem(0)
        objMsg.Subject = objForm.Name
        objMsg.Body = objForm.ScriptText
        objMsg.Display
End Sub

Egentligt var jeg ude efter en enkelt linie eller to!

Jeg har fundet ud af, at jeg kan benytte funktionen PickFolder, som giver mig lov til at vælge mappe manuelt.

Er der virkligt ikke en funktion, som giver lov til andet en at vælge blandt Outlooks standard mapper? (GetDefaultFolder)

Måske kan du finde det på en af disse adresse:

http://www.slipstick.com/dev/code/index.htm
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnout2k2/html/odc_olFAQ.asp?frame=true
http://www.microeye.com/resources/code.htm

Tak
Det ser ud til, at http://www.slipstick.com/dev/code/index.htm viser hvordan under
"To get a MAPIFolder object"

Her er den nemmeste løsning!

Set OlApp = GetObject("", "Outlook.Application")
Set currFldr = OlApp.ActiveExplorer.CurrentFolder

currFldr er navnet på den mappe, man er inde i.