# Macro to move from Outlook to Excel



## PondWaters (Mar 15, 2013)

Is there a macro that can move information form Outlook to Excel?

This might sound counter-productive, but the mail would come in with an excel attachment, I would just need it to add to another excel spreadsheet.  Basically the email coming in is a form that should only be used once, and I want that form to then feed to a master spreadsheet.  

The incoming form with the email would always have the information in the same cells.


----------



## SydneyGeek (Mar 17, 2013)

This is possible using automation, but if you use 2007 or higher and have Access there may be an easier route.
You can create a basic input form in Access that (1) is filled in as an Outlook email and (2) is imported as soon as the user replies.
Once you have the responses in Access you can pull data into Excel for analysis, or do some fairly serious slicing and dicing in Access before pulling the results into Excel. Worth a thought.
This is a link to a demo... Demo: Collect data in Access 2007 by using e-mail - Access - Office.com

Denis


----------



## PondWaters (Mar 19, 2013)

The issue with that is that it looks like attachments cannot be collected using email.  This would automatically come into an email address as an attachment, so that is where my problem lies.  Also, this could be used by any one of over 250 people, and we have a pretty high turnover rate.  

I would just like for the excel document to be housed on a SharePoint - that most people will have read only access to - and then sent via a click here to submit macro.

The document would be like the one linked.  Am I going to have to get very deep into vba, or is there an easier solution, or a possible workaround in Access?  I am new to Access, so any learning i could do would only be beneficial.

https://www.box.com/s/baawhaq8hj5zbsxrekb1


----------



## SydneyGeek (Mar 21, 2013)

If you want to strip attachments from emails, try the following. I put this together for automating data processing of Excel attachments. One of the things it does is strip attachments and move them to a network directory. Step 2 for my process (I flagged it as optional) is to run a routine in a processing workbook, to load the contents of the Excel attachment to a database. I didn't write the original Outlook code: I found it online and adapted it, but here it is.

Note: this code goes in Outlook. Some goes into ThisOutlookSession, some into a standard module -- check the comments. Once it's pasted into the modules, and you have changed to suit your folders, you will need to 
(1) Press Alt+F11 in Outlook, to bring up the editor. You will get a prompt about enabling macros; say OK.
(2) In ThisOutlookSession go to the end of the module, place your cursor in the SetTrigger routine and run it (F5) to start the monitoring process.

Do this each time you restart Outlook, or the process won't run.


```
''This code goes in your ThisOutlookSession module
Option Explicit
Private WithEvents olTestItems As Items
Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.Session
    ' instantiate objects declared WithEvents
    Set olTestItems = objNS.Folders("Mailbox - Wright, Denis").Folders("Test").Items 'change to suit your user name and folder
    Set objNS = Nothing
End Sub
Private Sub oltestitems_itemadd(ByVal item As Object)
    Dim xlApp As Object
    Dim xlWB As Object
    
    'On Error Resume Next
    'move the attachment to Attachments_Code_Test
    Call GetAttachments("Test", "Attachments_Code_Test") 'Attachments_code_test is your destination folder. Path is provided in the main module.
    
    're-run the Startup routine. Without this I found that the ItemAdd routine only ran once.
    Call Application_Startup
End Sub
Private Sub SetTrigger()
    Call Application_Startup
End Sub
''End of code for ThisOutlookSession
''This code goes into a new, standard Outlook module. save it as basAutomateExcel.
Option Explicit
Public gstrWhere As String
Public Sub GetAttachments(sFolder As String, sOutDir As String)
On Error GoTo GetAttachments_err
    Dim NS As NameSpace
    Dim F As MAPIFolder
    Dim item As Object
    Dim FileName As String
    Dim i As Integer
    Dim strFile As String
    Dim sNewFile As String
    Dim sDelAtts As String
    Dim sSavePathFS As String
    Dim x
    Dim sFolderID As String
    Dim xlApp As Object
    Dim xlWB As Object
    Const sPATH = "The full path and name for a processing workbook.xlsm" 'Change to suit, if the attachments require further processing use this workbook.
    Set NS = GetNamespace("MAPI")
    
    'for my environment:
    Select Case sFolder
        Case "Test": Set F = NS.Folders("Mailbox - Wright, Denis").Folders("Test")
    End Select
    
    i = 0
    
    If F.Items.Count = 0 Then
       MsgBox "There are no messages in this folder.", vbInformation, _
              "Nothing Found"
       Exit Sub
    End If
    
    'loop through the items, saving attachments to designated folder
    For Each item In F.Items
        'the While loop works better than For Each because the attachment list is re-indexed each time you add or remove an attachment
        While item.Attachments.Count > 0
            strFile = item.Attachments(1).FileName
            'use this for directing attachments to the G: drive
            FileName = "Directory path\change to suit\" & sOutDir & "\" & strFile
            x = Split(FileName, ".")
            sNewFile = x(0) & " " & Format(item.ReceivedTime, "yyyymmdd") & "." & x(1)
            item.Attachments(1).SaveAsFile sNewFile
            sDelAtts = ""
            If item.BodyFormat <> olFormatHTML Then
                sDelAtts = sDelAtts & vbCrLf & "<file://" & sNewFile & ">"
            Else
                sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sNewFile & "'>" & sNewFile & "</a>"
            End If
            ' Delete the current attachment. We use a "1" here instead of an "i"
            ' because the .Delete method will shrink the size of the item.Attachments
            ' collection for us. Use some well placed Debug.Print statements to see
            ' the behavior.
            item.Attachments(1).Delete
            
            'now rewrite the message to indicate where the attachment was saved
            ' Modify the body of the item to show the file system location of
            ' the deleted attachments.
            If item.BodyFormat <> olFormatHTML Then
                item.Body = item.Body & vbCrLf & vbCrLf _
                    & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
            Else
                item.HTMLBody = item.HTMLBody & "<p></p><p>" _
                    & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
            End If
            
            ' Save the edits to the item. If you forget this line, the attachments will not be deleted.
            item.Save
            
            'optional: now process the detached file
            If InStr(1, strFile, ".xls") > 0 Then ' only process Excel files: Modification 20120810 DW
                Set xlApp = CreateObject("Excel.Application")
                xlApp.Workbooks.Open (sPATH)
                Set xlWB = xlApp.ActiveWorkbook
                'run a macro in the workbook.
                'the comma syntax lets you define any parameters required.
                Select Case sFolder
                    Case "Test": xlApp.Run "HarvestTest", sNewFile
                End Select
                xlApp.ActiveWorkbook.Close (False)
                xlApp.Quit
                Set xlApp = Nothing
            End If
        Wend
    Next item
     
GetAttachments_exit:
    Set item = Nothing
    Set F = Nothing
    Set NS = Nothing
    gstrWhere = FileName
    Exit Sub
   
GetAttachments_err:
    MsgBox "An unexpected error has occurred." _
       & vbCrLf & "Please note and report the following information." _
       & vbCrLf & "Macro Name: GetAttachments" _
       & vbCrLf & "Error Number: " & Err.Number _
       & vbCrLf & "Error Description: " & Err.Description _
       , vbCritical, "Error!"
    'clean up references to prevent locking the file for later emails
    xlApp.ActiveWorkbook.Close (False)
    xlApp.Quit
    Set xlApp = Nothing
    Resume GetAttachments_exit
End Sub
```

Denis


----------



## PondWaters (Mar 22, 2013)

Wow, thank you!  I will definitely try this and report back!  You are awesome.


----------



## PondWaters (Mar 27, 2013)

Had to make a few adjustments, but the code seems to be working.


----------



## SydneyGeek (Mar 27, 2013)

Good to hear.

Denis


----------



## zraj07 (Dec 9, 2013)

SydneyGeek said:


> Good to hear.
> 
> Denis



Hi Sydney.

I keep getting an error message that my attachment can't be saved because the path does not exist.
I have tried a few ways to ensure I have the correct path (C:\rosen)
I also tried placing an Excel workbook in the folder called "testme.xls" and also altered the path in the VB macro to rflect that; c:\rosen\testme.xls

But I get the same error. I know that setting the path should be easy to figure out.
I have a folder in my inBox called Test. When I bring an email with an attached xls file into it, the macro runs, but tells it can't save the attachment.


This is from my OutlookSession module

  'move the attachment to Attachments_Code_Test
    Call GetAttachments("Test", "ROSEN") 'Attachments_code_test is your destination folder. Path is provided in the main module.

This is from the basAutomat module:
 Const sPATH = "C:\ROSEN" 'Change to suit, if the attachments require further processing use this workbook.
    Set NS = GetNamespace("MAPI")


I must be making a simple mistake. Any thoughts or guidance?


----------

