copy data from outlook email attachments to a local file

[s_samira_21]

Hi

I’m writing a vba code in outlook to open the excel attachments of the emails with a specific subject, and copy all data on it, then paste it in my excel file on my directory. the cod is here:

Option ExplicitDim WithEvents OLInboxItems As Items


Private Sub Application_Startup()


    Dim OLNS As Outlook.NameSpace


    Set OLNS = Application.GetNamespace("MAPI")
    Set OLInboxItems = OLNS.GetDefaultFolder(olFolderInbox).Items


End Sub


Private Sub olInboxItems_ItemAdd(ByVal Item As Object)


    On Error Resume Next


    Dim OLMailItem As MailItem
    Dim AttPath, AttName, UpFilePath


    If TypeOf Item Is MailItem Then
        Set OLMailItem = Item


        If OLMailItem.Attachments.Count > 0 _
          And OLMailItem.Subject = "AHOrdUpdate" Then


            AttName = OLMailItem.Attachments.Item(1).FileName
            AttPath = "D:\Projects\excel\TAC\Factory\TACDataManagement\Orders\AHOrders\Updates\" & AttName
            UpFilePath = "D:\Projects\excel\TAC\Factory\TAC Program\FDB.xlsm"
            OLMailItem.Attachments.Item(1).SaveAsFile AttPath


        End If


        Dim xlApp As Workbook, AttWB As Workbook, FDBWB As Workbook
        Dim AttWS As Worksheet, FDBWS As Worksheet
        Dim FDBWBCheck As Integer
        Dim CpyRng As Range
        
        Set xlApp = CreateObject("Excel.Application")


        With xlApp
            .Visible = True
            .EnableEvents = False
        End With


        Set AttWB = Workbooks.Open(AttPath)
        Set AttWS = AttWB.Sheets("sheet1")
        
        If FDBWB Is Nothing Then
            Set FDBWB = Workbooks.Open(UpFilePath)
            FDBWBCheck = 1
        End If
        
        Set FDBWS = FDBWB.Sheets("sheet1")


        'AttWS.Activate


        AttWB.Application.CutCopyMode = True
        
        CpyRng = ActualUsedRange(AttWS)
        
        CpyRng.Copy
        
        FDBWB.Cells(EndOfColumn(FDBWS, "A"), "A").PasteSpecial


        AttWB.Application.CutCopyMode = False
        


        AttWB.Close False
        
        If FDBWBCheck = 1 Then
            FDBWB.Close True
        End If
        
        FDBWB.Save
        
        Kill AttPath


    End If
    Set Item = Nothing
    Set OLMailItem = Nothing



End Sub

and here are the functions

'**********************************************************'
'*****Function to get the first empty row in a specific column:*****
Function EndOfColumn(ByRef WorkSheetName As Worksheet, ColumnName As String) As String


    EndOfColumn = 1
    
    If Not WorkSheetName.Cells(1, 1).Value = vbNullString Then
        EndOfColumn = WorkSheetName.Cells(Rows.Count, "ColumnName").End(xlUp).Row + 1
    End If


End Function

'**********************************************************'
'******Function to get the First Used Cell in a sheet:*****




Function FirstCellInSheet(ByRef WhichSheet As Worksheet) As Range
     
    'Declare Function Level Variables
    Dim FirstRow As Long
    Dim FirstColumn As Long
    Dim TempRange As Range
     
    'Initialize default values
    FirstRow = 1
    FirstColumn = 1
     
    'Get the first row that has data by setting the search direction
    'to Next and search order to by-Rows
    If WhichSheet.Cells(1, 1).Value = vbNullString Then
        Set TempRange = WhichSheet.Cells.Find("*", _
            , xlFormulas, xlPart, xlByRows, xlNext)
        If Not TempRange Is Nothing Then FirstRow = TempRange.Row
        'Get the last column that has data by setting the search direction
        'to Previous and search order to by-Columns
        Set TempRange = WhichSheet.Cells.Find("*", _
            , xlFormulas, xlPart, xlByColumns, xlNext)
        If Not TempRange Is Nothing Then FirstColumn = TempRange.Column
    End If
     
    'Return the First Cell
    Set FirstCellInSheet = WhichSheet.Cells.Item(FirstRow, FirstColumn)
 
End Function

'**********************************************************'
'*****Function to get the Last Used Cell in a sheet:*****
Function LastCellInSheet(ByRef WhichSheet As Worksheet) As Range
 
    'Declare Function Level Variables
    Dim TempRange As Range
    Dim LastRow As Long
    Dim LastColumn As Long
     
    'Initialize default values
    LastRow = 1
    LastColumn = 1
     
    'Get the last row that has data by setting the search direction
    'to Previous and search order to by-Rows
    Set TempRange = WhichSheet.Cells.Find("*", _
        , xlFormulas, xlPart, xlByRows, xlPrevious)
    If Not TempRange Is Nothing Then LastRow = TempRange.Row
    'Get the last column that has data by setting the search direction
    'to Previous and search order to by-Columns
    Set TempRange = WhichSheet.Cells.Find("*", _
        , xlFormulas, xlPart, xlByColumns, xlPrevious)
    If Not TempRange Is Nothing Then LastColumn = TempRange.Column
     
    'Return the Last Cell
    Set LastCellInSheet = WhichSheet.Cells.Item(LastRow, LastColumn)
 
End Function

'**********************************************************'
'*****Function to get the Actual Used Range in a sheet:*****
Function ActualUsedRange(Optional ByRef WhichSheet As Worksheet, _
    Optional ByVal FromTheTop As Boolean = False) As Range
 
Dim LastCell As Range
Dim FirstCell As Range
 
'If WhichSheet Is Nothing Then
'    Set WhichSheet = Application.ActiveSheet
'End If
 
'Get the Last Cell
Set LastCell = LastCellInSheet(WhichSheet)
 
'Get the First Cell
If FromTheTop Then
    Set FirstCell = WhichSheet.Cells.Item(1, 1)
Else
    Set FirstCell = FirstCellInSheet(WhichSheet)
End If
 
'Return the Used Range
Set ActualUsedRange = Range(FirstCell, LastCell)
 
End Function

I used http://strugglingtoexcel.wordpress.c...1/#comment-320 to write these functions.


The problem is that, when I run the code nothing happens!

Actually, when I run my code step by step, I see that the workbook,worksheet and range variables remain empty!

please help me

Thank you

Regards