|
09-17-2014, 11:32 PM
|
|
Novice
|
|
Join Date: Aug 2014
Posts: 7
|
|
my Job That doesnt work when a new mail receives
I wrote this code base on my googling data, in thisOutlookSession.
this code is like the one you kindly wrote for me.
But when I receive a new mail, nothing happens
Quote:
Option Explicit
Dim 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
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 = "G:\Projects\Excel\TAC\TAC Data Management\Orders\AHOrders\Updates\updates\" + AttName
OLMailItem.Attachments.Item(1).SaveAsFile AttPath
End If
'---------------------
Dim xlApp, AttWB, UpdateWB, AttWS, UpdateWS As Object
Dim rng As Range
Dim AttEOC, AttEOR, EOC As Integer
'-----------------------
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
Set AttWB = Workbooks.Open(AttPath, , False, , , , , , , True)
AttWB.Activate
Set AttWS = AttWB.sheets("sheet1")
With AttWS
Set AttEOC = Application.WorksheetFunction.CountA("A:A")
Set AttEOR = Application.WorksheetFunction.CountA("1:1")
Set rng = .Range("A1:" & AttEOR & AttEOC)
rng.Copy
.Close Save:=False
End With
'-------------------------------
'----------------------------
Set UpdateWB = Workbooks.Open("G:\Projects\Excel\TAC\TAC Data Management\Orders\AHOrders\Updates\updates.xlsx", , False, , , , , , , True)
UpdateWB.Activate
Set UpdateWS = UpdateWB.sheets("sheet1")
With UpdateWS
Set EOC = .cells(Rows.Count, "A").End(xlUp).Row
.cells(EOC, "A").Paste
.Close Save:=True
End With
'-----------------------------------------------
End If
Set Item = Nothing
Set OLMailItem = Nothing
End Sub
|
|