• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 495
  • Last Modified:

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..
0
route217
Asked:
route217
  • 6
  • 3
1 Solution
 
gowflowCommented:
what is the name of the folder the email reside on ?
gowflow
0
 
route217Author Commented:
CM Template
0
 
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
     
    Next
     
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
.
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
route217Author Commented:
Afternoon glow flow

Any development on the macro
0
 
gowflowCommented:
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 ?
0
 
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:

Code:
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
Else
    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
DoEvents

Next oMessage
SaveAttachments = True

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


Code:
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
0
 
gowflowCommented:
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.

gowflow
saveattachments.xls
0
 
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...
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

  • 6
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now