Dim appOl As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Dim sFilter As String
Dim strPath As String
Dim strFile As String
Dim sFileText As String
Dim iFileNo As Integer
Dim strLog As String
Dim fso As New FileSystemObject
iFileNo = FreeFile
GetIniDef "", ""
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
If Dir$("D:/ETMP" & Format(Date, "ddmmyyyy") & "/", vbDirectory) =
vbNullString Then
MkDir "D:/ETMP" & Format(Date, "ddmmyyyy") & "/"
End If
strPath = "D:/ETMP" & Format(Date, "ddmmyyyy") & "/"
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
WriteLog ("There are no messages in the Inbox.Nothing Found")
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "TXT" Or Right(Atmt.FileName, 3)
= "txt" Then
' This path must exist! Change folder name as necessary.
If (Format(Item.CreationTime, "yyyymmdd") = Format(Date,
"yyyymmdd") And Format(Item.CreationTime, "hh:mm:ss") < "15:30:00") Or
(Format(Item.CreationTime, "yyyymmdd") = Format(Date - 1, "yyyymmdd")
And Format(Item.CreationTime, "hh:mm:ss") >= "15:30:00") Then
FileName = strPath & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
End If
Next Atmt
Next Item
'read files from folder
strFile = Dir(strPath)
........................