Modification Needed on this Macro

krishhi · Aug 20, 2011

Hi Guys,

I have this macro, it will download the attachemnts to a particular folder from the selected mail. But I want to edit the macro like below specifications.

1. Macro should ask the ask user for the parth.
2. When it is saving attachemnts, it should save the attachemnts In a New Folder and Name the Folder with "Mail Subject"

Here is the Code:

Code:

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 = CreateObject("Outlook.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 = strFolderpath & "\OLAttachments\"
    ' 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

Waiting for the Kind Reply,

Krrish

krishhi · Aug 20, 2011

Any Help Guys

jbeaucaire · Aug 20, 2011

Give this a try:

Code:

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

'Folder selection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = "C:\"
        .Show
        If .SelectedItems.Count > 0 Then strFolderpath = .SelectedItems(1) & "\"
    End With
    
'create new target folder in chosen path
    On Error Resume Next
' Set the Attachment folder.
    strFolderpath = strFolderpath & "\Mail Subject\"
    MkDir strFolderpath
    
' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
' 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 objMsg
    
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

AlphaFrog · Aug 20, 2011

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 strSubfolder As String Dim strDeletedFiles As String Dim InvalidPathChars As Variant InvalidPathChars = Array("*", "|", "/", "\", ":", """", "<", ">", ".", "?") ' Get the path to your My Documents folder ' strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) ' Prompt user to select a folder With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = CreateObject("WScript.Shell").SpecialFolders(16) ' Default path .Title = "Please Select a Destination Folder" .ButtonName = "Select Folder" .AllowMultiSelect = False .Show If .SelectedItems.Count = 0 Then Exit Sub ' User clicked cancel strFolderpath = .SelectedItems.Item(1) & Application.PathSeparator End With 'On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.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 = strFolderpath & "\OLAttachments\" ' 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. 'create sub folder strSubfolder = Left(objMsg.Subject, 20) 'Limit folder name to 20 characters For i = 0 To UBound(InvalidPathChars) strSubfolder = Replace(strSubfolder, InvalidPathChars(i), "_") Next i strSubfolder = strSubfolder & Application.PathSeparator If Dir(strFolderpath & strSubfolder) = "" Then MkDir strFolderpath & strSubfolder For i = lngCount To 1 Step -1 ' Get the file name. strFile = objAttachments.Item(i).Filename ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFolderpath & strSubfolder & strFile Next i End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub

krishhi · Aug 21, 2011

jbeaucaire AND AlphaFrog

Thank you very much guys for your reply, But When i am trying to run these code, i am getting error, at this point.

Code:

With Application.FileDialog(msoFileDialogFolderPicker)

Error Message:

Run-time error '438':
Object doesn't support this property or method

By the way i am using Microsoft Office 2007.

Waiting for your kind reply

VoG · Aug 21, 2011

That portion of the code works for me (Excel 2010 and it should work at least back to Excel 2003). Do you still get that error with

Code:

Sub atest()
Dim strFolderpath As String
 With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = "C:\"
        .Show
        If .SelectedItems.Count > 0 Then strFolderpath = .SelectedItems(1) & "\"
    End With
MsgBox strFolderpath
End Sub

krishhi · Aug 22, 2011

VoG said:
That portion of the code works for me (Excel 2010 and it should work at least back to Excel 2003). Do you still get that error with

Code:

Sub atest() Dim strFolderpath As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .InitialFileName = "C:\" .Show If .SelectedItems.Count > 0 Then strFolderpath = .SelectedItems(1) & "\" End With MsgBox strFolderpath End Sub

VOG,

Thank you very much for the reply, I am using Office 2007, the code won't work in that. It gives the error as i said above? I have outlook express, but there is no option for macro [vba editor] to paste that code

krishhi · Aug 23, 2011

I Even tried in Office 2010, but no luck. Any Help guys?

krishhi · Aug 24, 2011

Here is a screenshot of the error i am getting

AlphaFrog · Aug 24, 2011

I don't know why you get that error.

As a quick test, try this...

 ' Prompt user to select a folder With Application.FileDialog(4) 'With Application.FileDialog(msoFileDialogFolderPicker) '.InitialFileName = CreateObject("WScript.Shell").SpecialFolders(16) ' Default path .Title = "Please Select a Destination Folder" .ButtonName = "Select Folder" .AllowMultiSelect = False .Show If .SelectedItems.Count = 0 Then Exit Sub ' User clicked cancel strFolderpath = .SelectedItems.Item(1) & Application.PathSeparator End With

It's a guess. If it doesn't work, go back to the original.

Under the VBA menu Tools\ References, what references do you have checked? Please list all.

Modification Needed on this Macro

krishhi

Active Member

Excel Facts

krishhi

Active Member

jbeaucaire

Well-known Member

AlphaFrog

MrExcel MVP

krishhi

Active Member

VoG

Legend

krishhi

Active Member

krishhi

Active Member

krishhi

Active Member

AlphaFrog

MrExcel MVP

Similar threads

Forum statistics

Share this page

Modification Needed on this Macro

Active Member

Excel Facts

Active Member

Well-known Member

MrExcel MVP

Active Member

Legend

Active Member

Active Member

Active Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock