Macro to copy file attachment from incoming email and save to location on c: drive

Hi Experts

How would you create a macro that copies an excel file attachment from an incoming email that's going to a central mail box and save a copy of the file to a location on the c: drive..
Who is Participating?
gowflowConnect With a Mentor Commented:
wait wait !!!!
the code you posted first is fine I made some small ammendments for it to work. The way it work (this is a temp solution if you like it then will find a better way to incorporate it) I will attach it to Excel file first you do this:

1) open outlook and locate the email and highlight it (just click on it) then run the excel make sure you enable macroes and click on the button Save File to C and then go to you Documents and look for folder OLAttachments and see what is there.

Let me know we can modify this to look for a complete folder and incorporate it to outlook so it is less cumbersome.

what is the name of the folder the email reside on ?
route217Author Commented:
CM Template
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

route217Author Commented:
Here is a file I have found which might do the job..

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
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
route217Author Commented:
Afternoon glow flow

Any development on the macro
Sorry was out and we hv snow storm here could not connect earlier. Yoiu mention your folder is CM Template but you didn't mention what is the path ?
route217Author Commented:
Hi glow flow

U can use c:\mydocument and ill change the file path later on...

Also I managed to find the follow vba whilst searching the web but cannot see how to change the code to extract any attachment coming on the cmu template email folder:

Option Explicit
Private Const MAX_PATH = 255

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Then a couple of Functions:

Public Function SaveAttachments(Optional PathName As String) As Boolean

Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim sPathName As String
Dim oAttachment As Outlook.Attachment
Dim iCtr As Integer
Dim iAttachCnt As Integer

On Error GoTo ErrHandler

If PathName = "" Then
    sPathName = GetTempDir
    sPathName = PathName
End If

If Right(sPathName, 1) <> "\" Then sPathName = sPathName & "\"
If Dir(sPathName, vbDirectory) = "" Then Exit Function

Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
For Each oMessage In oFldr.Items
With oMessage.Attachments
    iAttachCnt = .Count
    If iAttachCnt > 0 Then
        For iCtr = 1 To iAttachCnt
            .Item(iCtr).SaveAsFile sPathName _
                 & .Item(iCtr).FileName
        Next iCtr
    End If
End With

Next oMessage
SaveAttachments = True

Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Function

Public Function GetTempDir() As String
    Dim sRet As String, lngLen As Long
    'create buffer
    sRet = String(MAX_PATH, 0)
    lngLen = GetTempPath(MAX_PATH, sRet)
    If lngLen = 0 Then Err.Raise Err.LastDllError
    GetTempDir = Left$(sRet, lngLen)
End Function

And your attachments are now in the folder!
Criticism comes easier than Craftmanship
route217Author Commented:
Hi glow flow this is why I am after

"Let me know we can modify this to look for a complete folder and incorporate it to outlook so it is less cumbersome."

I'll post second part to this question...

Pa what do the second macro do...
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.