Save Attachments from Outlook Public Folders to Hard Drive

[wazimb]

I run the below macro, by going to a public folder in Outlook, selecting all files (all are excel spreadsheets), and click run macro. It stores my attachments in 1 folder. I use a separate macro to grab all current month files and combine all files into 1 spreadsheet.

I would like to combine the request, clicking run macro in excel. It would need to access the public outlook folder (path.... Public Folders>Finance>Inventory>CycleTime>August 2018), grab all attachments, save them to the applicable months folder (based on date email received), and combine files into 1 sheet. Is this possible?


I can figure out how to combine the spreadsheets I am just having trouble tell the macro to access a public folder to grab the items.


OUTLOOK MACRO

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = Application

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' The attachment folder needs to exist
' You can change this to another folder name of your choice

' Set the Attachment folder.
strFolderpath = "MYDOCFOLDERLOCATION"

' Check each selected item for attachments.
For Each objMsg In objSelection

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then

' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.

For i = lngCount To 1 Step -1

' Get the file name.
strFile = objAttachments.Item(i).FileName

' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile

' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile

Next i
End If

Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

 

[Kenneth Hobson]

Welcome to the forum!

I am not sure what you mean by Outlook public folders.

To use this function, you need to send it the folderpath and the Outlook object. If it exists, it will return an Outlook.Folder object.

The first routine shows how to get the folderpath for an open Outlook folder that is selected. The 2nd is a short example showing how to use the function.

e.g.

'Outlook or Excel Code to get FolderPath:
Sub GetActiveFolderPath()
  Debug.Print Outlook.ActiveExplorer.CurrentFolder.FolderPath
End Sub


Sub Test_GetFolderPath()
  Dim oL As Outlook.Application, oLf As Outlook.Folder
  Set oL = CreateObject("Outlook.Application")
  Set oLf = GetFolderPath("\\kenneth.ray.hobson@gmail.com\InBox\[Gmail]", oL)
  MsgBox oLf.Name, , oLf.Items.Count
  Set oLf = Nothing
  Set oL = Nothing
End Sub


'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As Outlook.Application) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
        
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
        
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

 

[snb]

All you need is:

Sub M_snb_attsave()
    With CreateObject("outlook.application")
        For Each it In .GetNamespace("Mapi").GetDefaultFolder(6).Items
           For Each it1 In it.Attachments
               it1.SaveAsFile "C:\" & it1.FileName
           Next
        Next
    End With
End Sub