s_samira_21
New Member
- Joined
- Sep 11, 2014
- Messages
- 9
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:
and here are the functions
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
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:
Code:
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
Code:
'**********************************************************'
'*****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
Code:
'**********************************************************'
'******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
Code:
'**********************************************************'
'*****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
Code:
'**********************************************************'
'*****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