How to locate a new outlook folder

[Jamie]

Hi There

I am quite inexperienced using VBA but have managed to put the
following piece of code together that nearly does exactly what I need.

Basically when I receive an email with a certain subject heading
outlook opens a spreadsheet which auto runs this macro to search my
inbox for emails with taht subject heading and processes the
attachment.

My only problem is that I dont want it to search my Inbox I want it to
search my sub folder Inbox1. I know this may seem a simple request but
I have tried and I have no idea how to do it.

Any help would be greatfully appreciated.

Thanks in advance

Jamie

Code:


Sub auto_open()

Windows("EIS Job Log test.xls").Activate
Range("B2").Select



Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim i As Long

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("eisreq")
MyPath = "I:\EIS\Forms\EIS Requests\"
dattim = Format(Date, "yyyymmdd") & " " & "Time-" & Format(Time,
"hhmmss")


For i = Fldr.Items.Count To 1 Step -1
Range("A1").Select


rowlength = Selection.CurrentRegion.Rows.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "EIS_REQUEST") > 0 Then
For Each olAtt In olMi.Attachments
If olAtt.Filename = "EIS Request.xls" Then
olAtt.SaveAsFile MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
open1 = MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
filenm = Fldr.Items.Count & " " & olMi.SenderName &
" " & "Date-" & dattim & ".xls"
End If

Next olAtt
olMi.save
olMi.Move MoveToFldr
Workbooks.Open Filename:=open1

'copies and pastes data from eis request
Range("IR4:IV4").Select
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("A1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 1).Select
End If
Next x
Selection.PasteSpecial paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes filename
Range("E1").Select
For x = 1 To rowlength
If ActiveCell.Cells <> "" Then
Cells(ActiveCell.Row + 1, 6).Select
End If
Next x
ActiveCell = filenm

Windows(filenm).Activate
ActiveWorkbook.Close False

Windows("EIS Job Log test.xls").Activate
ActiveWorkbook.save

End If
Next i
ActiveWorkbook.Close False
Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub